diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin -version: 1.1.1.0 +version: 1.1.2.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -19,11 +19,13 @@ extra-source-files: LICENSE README.md + test/cabal.project + test/info-util/*.cabal + test/info-util/*.hs test/testdata/*.cabal test/testdata/*.hs test/testdata/*.lhs test/testdata/*.yaml - test/testdata/cabal.project flag pedantic description: Enable -Werror @@ -59,12 +61,11 @@ , extra , filepath , ghc - , ghc-api-compat , ghc-boot-th , ghc-paths , ghcide >=1.2 && <1.5 , hashable - , hls-plugin-api ^>=1.1 + , hls-plugin-api ^>=1.2 , lens , lsp , lsp-types @@ -81,6 +82,22 @@ , unliftio , unordered-containers + if impl(ghc < 8.10.5) + build-depends: + ghc-api-compat ==8.6 + elif impl(ghc == 8.10.5) + build-depends: + ghc-api-compat ==8.10.5 + elif impl(ghc == 8.10.6) + build-depends: + ghc-api-compat ==8.10.6 + elif impl(ghc == 8.10.7) + build-depends: + ghc-api-compat ==8.10.7 + elif impl(ghc == 9.0.1) + build-depends: + ghc-api-compat ==9.0.1 + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors @@ -105,6 +122,7 @@ , extra , filepath , hls-eval-plugin - , hls-test-utils ^>=1.0 + , hls-test-utils ^>=1.1 , lens , lsp-types + , text diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} -- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) @@ -13,7 +13,6 @@ import Development.IDE.Types.Location (Position (..), Range (..)) import GHC (ExecOptions, ExecResult (..), execStmt) -import GHC.LanguageExtensions.Type (Extension (..)) import GhcMonad (Ghc, liftIO, modifySession) import HscTypes import Ide.Plugin.Eval.Types (Language (Plain), Loc, @@ -81,15 +80,6 @@ asStmts (Property t _ _) = ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] --- |GHC extensions required for expression evaluation -evalExtensions :: [Extension] -evalExtensions = - [ OverlappingInstances - , UndecidableInstances - , FlexibleInstances - , IncoherentInstances - , TupleSections - ] -- |GHC declarations required for expression evaluation evalSetup :: Ghc () diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -40,7 +40,7 @@ import qualified Data.DList as DL import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, - intercalate) + intercalate, intersperse) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe) import Data.String (IsString) @@ -84,7 +84,9 @@ import Development.IDE.Types.Options import DynamicLoading (initializePlugins) import FastString (unpackFS) -import GHC (ExecOptions (execLineNumber, execSourceFile), +import GHC (ClsInst, + ExecOptions (execLineNumber, execSourceFile), + FamInst, Fixity, GeneralFlag (..), Ghc, GhcLink (LinkInMemory), GhcMode (CompManager), @@ -92,28 +94,38 @@ HscTarget (HscInterpreted), LoadHowMuch (LoadAllTargets), ModSummary (ms_hspp_opts), + NamedThing (getName, getOccName), SuccessFlag (Failed, Succeeded), TcRnExprMode (..), + TyThing, defaultFixity, execOptions, exprType, + getInfo, getInteractiveDynFlags, getSessionDynFlags, isImport, isStmt, load, - runDecls, setContext, - setLogAction, + parseName, pprFamInst, + pprInstance, runDecls, + setContext, setLogAction, setSessionDynFlags, setTargets, typeKind) +import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import GhcPlugins (DynFlags (..), defaultLogActionHPutStrDoc, - gopt_set, gopt_unset, - hsc_dflags, + elemNameSet, gopt_set, + gopt_unset, hsc_dflags, + isSymOcc, mkNameSet, parseDynamicFlagsCmdLine, - targetPlatform, xopt_set) + pprDefinedAt, + pprInfixName, + targetPlatform, + tyThingParent_maybe, + xopt_set, xopt_unset) + import HscTypes (InteractiveImport (IIModule), ModSummary (ms_mod), Target (Target), TargetId (TargetFile)) import Ide.Plugin.Eval.Code (Statement, asStatements, - evalExtensions, evalSetup, myExecStmt, propSetup, resultRange, testCheck, testRanges) @@ -129,19 +141,29 @@ response', timed) import Ide.Types import Language.LSP.Server -import Language.LSP.Types +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length)) import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) -import Outputable (nest, ppr, showSDoc, - text, ($$), (<+>)) +import Outputable (SDoc, empty, hang, nest, + ppr, showSDoc, text, + vcat, ($$), (<+>)) import System.FilePath (takeFileName) import System.IO (hClose) import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) - +import IfaceSyn (showToHeader) +import PprTyThing (pprTyThingInContext, + pprTypeForUser) #if MIN_VERSION_ghc(9,0,0) -import GHC.Parser.Annotation (ApiAnns (apiAnnComments)) +import GHC.Driver.Ways (hostFullWays, + wayGeneralFlags, + wayUnsetGeneralFlags) +import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments)) +import GHC.Parser.Lexer (mkParserFlags) +import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else import GhcPlugins (interpWays, updateWays, wayGeneralFlags, @@ -151,9 +173,11 @@ #if MIN_VERSION_ghc(9,0,0) pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x +apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment] +apiAnnComments' = apiAnnRogueComments #else -apiAnnComments :: SrcLoc.ApiAnns -> Map.Map SrcSpan [SrcLoc.Located AnnotationComment] -apiAnnComments = snd +apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment] +apiAnnComments' = concat . Map.elems . snd pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x @@ -175,9 +199,9 @@ isLHS = isLiterate fp dbg "fp" fp (ParsedModule{..}, posMap) <- liftIO $ - runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp - let comments = foldMap - ( foldMap $ \case + runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp + let comments = + foldMap (\case L (RealSrcSpanAlready real) bdy | unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp @@ -195,16 +219,15 @@ _ -> mempty _ -> mempty ) - $ apiAnnComments pm_annotations + $ apiAnnComments' pm_annotations dbg "excluded comments" $ show $ DL.toList $ - foldMap - (foldMap $ \(L a b) -> + foldMap (\(L a b) -> case b of AnnLineComment{} -> mempty AnnBlockComment{} -> mempty _ -> DL.singleton (a, b) ) - $ apiAnnComments pm_annotations + $ apiAnnComments' pm_annotations dbg "comments" $ show comments -- Extract tests from source code @@ -302,8 +325,13 @@ -- copy the package state to the interactive DynFlags idflags <- getInteractiveDynFlags df <- getSessionDynFlags - setInteractiveDynFlags $ - (foldl xopt_set idflags evalExtensions) + -- set the identical DynFlags as GHCi + -- Source: https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483 + -- This needs to be done manually since the default flags are not visible externally. + let df' = flip xopt_set LangExt.ExtendedDefaultRules + . flip xopt_unset LangExt.MonomorphismRestriction + $ idflags + setInteractiveDynFlags $ df' #if MIN_VERSION_ghc(9,0,0) { unitState = unitState @@ -526,7 +554,7 @@ eans <- liftIO $ try @GhcException $ parseDynamicFlagsCmdLine ndf - (map (L $ UnhelpfulSpan "") flags) + (map (L $ UnhelpfulSpan unhelpfulReason) flags) dbg "parsed flags" $ eans <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg) case eans of @@ -552,7 +580,7 @@ Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = evalGhciLikeCmd cmd arg | -- A statement - isStmt df stmt = + isStmt pf stmt = do dbg "{STMT " stmt res <- exec stmt l @@ -562,7 +590,7 @@ dbg "STMT} -> " r return r | -- An import - isImport df stmt = + isImport pf stmt = do dbg "{IMPORT " stmt _ <- addImport stmt @@ -573,6 +601,13 @@ dbg "{DECL " stmt void $ runDecls stmt return Nothing +#if !MIN_VERSION_ghc(9,0,0) + pf = df + unhelpfulReason = "" +#else + pf = mkParserFlags df + unhelpfulReason = UnhelpfulInteractive +#endif exec stmt l = let opts = execOptions{execSourceFile = fp, execLineNumber = l} in myExecStmt stmt opts @@ -651,7 +686,12 @@ -- Should we use some sort of trie here? ghciLikeCommands :: [(Text, GHCiLikeCmd)] ghciLikeCommands = - [("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)] + [ ("info", doInfoCmd False) + , ("info!", doInfoCmd True) + , ("kind", doKindCmd False) + , ("kind!", doKindCmd True) + , ("type", doTypeCmd) + ] evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) evalGhciLikeCmd cmd arg = do @@ -665,24 +705,69 @@ <$> hndler df arg _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg +doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) +doInfoCmd allInfo dflags s = do + sdocs <- mapM infoThing (T.words s) + pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs) + where + infoThing :: GHC.GhcMonad m => Text -> m SDoc + infoThing (T.unpack -> str) = do + names <- GHC.parseName str + mb_stuffs <- mapM (GHC.getInfo allInfo) names + let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t) + (catMaybes mb_stuffs) + return $ vcat (intersperse (text "") $ map pprInfo filtered) + + filterOutChildren :: (a -> TyThing) -> [a] -> [a] + filterOutChildren get_thing xs + = filter (not . has_parent) xs + where + all_names = mkNameSet (map (getName . get_thing) xs) + has_parent x = case tyThingParent_maybe (get_thing x) of + Just p -> getName p `elemNameSet` all_names + Nothing -> False + + pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc + pprInfo (thing, fixity, cls_insts, fam_insts, docs) + = docs + $$ pprTyThingInContextLoc thing + $$ showFixity thing fixity + $$ vcat (map GHC.pprInstance cls_insts) + $$ vcat (map GHC.pprFamInst fam_insts) + + pprTyThingInContextLoc :: TyThing -> SDoc + pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext showToHeader tyThing) + + showWithLoc :: SDoc -> SDoc -> SDoc + showWithLoc loc doc + = hang doc 2 (text "\t--" <+> loc) + + showFixity :: TyThing -> Fixity -> SDoc + showFixity thing fixity + | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing) + = ppr fixity <+> pprInfixName (GHC.getName thing) + | otherwise = empty + doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) doKindCmd False df arg = do let input = T.strip arg (_, kind) <- typeKind False $ T.unpack input - let kindText = text (T.unpack input) <+> "::" <+> ppr kind + let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind pure $ Just $ T.pack (showSDoc df kindText) doKindCmd True df arg = do let input = T.strip arg (ty, kind) <- typeKind True $ T.unpack input - let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind - tyDoc = "=" <+> ppr ty + let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind + tyDoc = "=" <+> pprTypeForUser ty pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do let (emod, expr) = parseExprMode arg ty <- exprType emod $ T.unpack expr - let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty + let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty broken = T.any (\c -> c == '\r' || c == '\n') rawType pure $ Just $ @@ -691,7 +776,7 @@ T.pack $ showSDoc dflags $ text (T.unpack expr) - $$ nest 2 ("::" <+> ppr ty) + $$ nest 2 ("::" <+> pprTypeForUser ty) else expr <> " :: " <> rawType <> "\n" parseExprMode :: Text -> (TcRnExprMode, T.Text) @@ -734,13 +819,18 @@ , ghcLink = LinkInMemory } platform = targetPlatform dflags3 - dflags3a = updateWays $ dflags3{ways = interpWays} +#if MIN_VERSION_ghc(9,0,0) + evalWays = hostFullWays +#else + evalWays = interpWays +#endif + dflags3a = dflags3{ways = evalWays} dflags3b = foldl gopt_set dflags3a $ - concatMap (wayGeneralFlags platform) interpWays + concatMap (wayGeneralFlags platform) evalWays dflags3c = foldl gopt_unset dflags3b $ - concatMap (wayUnsetGeneralFlags platform) interpWays + concatMap (wayUnsetGeneralFlags platform) evalWays dflags4 = dflags3c `gopt_set` Opt_ImplicitImportQualified diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,22 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Main ( main ) where -import Control.Lens (_Just, preview, view) -import Control.Monad (when) +import Control.Lens (_Just, preview, toListOf, view) import Data.Aeson (fromJSON) import Data.Aeson.Types (Result (Success)) +import Data.List (isInfixOf) import Data.List.Extra (nubOrdOn) import qualified Ide.Plugin.Eval as Eval -import Ide.Plugin.Eval.Types (EvalParams (..)) -import Language.LSP.Types.Lens (command, range, title) -import System.Directory (doesFileExist) -import System.FilePath ((<.>), ()) +import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), + testOutput) +import Language.LSP.Types.Lens (arguments, command, range, title) +import System.FilePath (()) import Test.Hls +import qualified Data.Text as T main :: IO () main = defaultTestRunner tests @@ -60,7 +62,14 @@ , goldenWithEval "Refresh an evaluation" "T5" "hs" , goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs" , goldenWithEval "Refresh a multiline evaluation" "T7" "hs" - , goldenWithEval "Semantic and Lexical errors are reported" "T8" "hs" + , testCase "Semantic and Lexical errors are reported" $ do + evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" + evalInFile "T8.hs" "-- >>> \"a\" + \"bc\"" $ + if ghcVersion == GHC90 + then "-- No instance for (Num String) arising from a use of ‘+’" + else "-- No instance for (Num [Char]) arising from a use of ‘+’" + evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input" + evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" , goldenWithEval "Evaluate a type with :kind!" "T10" "hs" , goldenWithEval "Reports an error for an incorrect type with :kind!" "T11" "hs" @@ -74,9 +83,24 @@ , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" , expectFailBecause "known issue - see a note in P.R. #361" $ goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs" - , goldenWithEval ":type handles a multilined result properly" "T21" "hs" + , testCase ":type handles a multilined result properly" $ + evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ + "-- fun", + if ghcVersion == GHC90 + then "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." + else "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- (KnownNat k2, KnownNat n, Typeable a) =>", + "-- Proxy k2 -> Proxy n -> Proxy a -> ()" + ] , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs" - , goldenWithEval ":type does \"dovetails\" for short identifiers" "T23" "hs" + , testCase ":type does \"dovetails\" for short identifiers" $ + evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ + if ghcVersion == GHC90 + then "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." + else "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- (KnownNat k2, KnownNat n, Typeable a) =>", + "-- Proxy k2 -> Proxy n -> Proxy a -> ()" + ] , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs" , goldenWithEval ":kind treats a multilined result properly" "T25" "hs" , goldenWithEval "local imports" "T26" "hs" @@ -90,6 +114,11 @@ -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" , goldenWithEval ":set accepts ghci flags" "TFlags" "hs" + , testCase ":set -fprint-explicit-foralls works" $ do + evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" + evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" + "-- id :: forall {a}. a -> a" + , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" , goldenWithEval "Property checking" "TProperty" "hs" , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" @@ -97,21 +126,66 @@ , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs" , goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs" , testGroup "with preprocessors" - [ knownBrokenInEnv [HostOS Windows, GhcVer GHC84, GhcVer GHC86] + [ knownBrokenInEnv [HostOS Windows, GhcVer GHC86] "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $ goldenWithEval "CPP support" "TCPP" "hs" - , knownBrokenForGhcVersions [GHC84, GHC86] + , knownBrokenForGhcVersions [GHC86] "Preprocessor known to fail on GHC <= 8.6" $ goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs" -- , goldenWithEval "Literate Haskell LaTeX Style" "TLHSLateX" "lhs" ] , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs" , goldenWithEval "Variable 'it' works" "TIt" "hs" + + , testGroup ":info command" + [ testCase ":info reports type, constructors and instances" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + , testCase ":info reports type, constructors and instances for multiple types" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoMany.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration" + "Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar" + "Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar" + not ("Baz Bar" `isInfixOf` output) @? "Output includes instance Baz Bar" + , testCase ":info! reports type, constructors and unfiltered instances" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBang.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + "Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo" + , testCase ":info! reports type, constructors and unfiltered instances for multiple types" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfoBangMany.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + "Baz Foo" `isInfixOf` output @? "Output does not include instance Baz Foo" + "data Bar = Bar1 | Bar2 | Bar3" `isInfixOf` output @? "Output does not include Bar data declaration" + "Eq Bar" `isInfixOf` output @? "Output does not include instance Eq Bar" + "Ord Bar" `isInfixOf` output @? "Output does not include instance Ord Bar" + "Baz Bar" `isInfixOf` output @? "Output does not include instance Baz Bar" + , testCase ":i behaves exactly the same as :info" $ do + [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TI_Info.hs" + "data Foo = Foo1 | Foo2" `isInfixOf` output @? "Output does not include Foo data declaration" + "Eq Foo" `isInfixOf` output @? "Output does not include instance Eq Foo" + "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" + not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" + ] ] goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree -goldenWithEval title path ext = goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext $ \doc -> do - -- Execute lenses backwards, to avoid affecting their position in the source file +goldenWithEval title path ext = + goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards + +-- | Execute lenses backwards, to avoid affecting their position in the source file +executeLensesBackwards :: TextDocumentIdentifier -> Session () +executeLensesBackwards doc = do codeLenses <- reverse <$> getCodeLenses doc -- liftIO $ print codeLenses @@ -133,5 +207,29 @@ -- liftIO $ print _resp pure () +evalLenses :: FilePath -> IO [CodeLens] +evalLenses path = runSessionWithServer evalPlugin testDataDir $ do + doc <- openDoc path "haskell" + executeLensesBackwards doc + getCodeLenses doc + +codeLensTestOutput :: CodeLens -> [String] +codeLensTestOutput codeLens = do + CodeLens { _command = Just command } <- [codeLens] + Command { _arguments = Just (List args) } <- [command] + Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args + Section { sectionTests = sectionTests } <- sections + testOutput =<< sectionTests + testDataDir :: FilePath testDataDir = "test" "testdata" + +evalInFile :: FilePath -> T.Text -> T.Text -> IO () +evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do + doc <- openDoc fp "haskell" + origin <- documentContents doc + let withEval = origin <> e + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing withEval] + executeLensesBackwards doc + result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc + liftIO $ result @?= Just (T.strip expected) diff --git a/test/cabal.project b/test/cabal.project new file mode 100644 --- /dev/null +++ b/test/cabal.project @@ -0,0 +1,3 @@ +packages: + testdata/ + info-util/ diff --git a/test/info-util/InfoUtil.hs b/test/info-util/InfoUtil.hs new file mode 100644 --- /dev/null +++ b/test/info-util/InfoUtil.hs @@ -0,0 +1,20 @@ +module InfoUtil + ( Eq + , Ord + , Foo (..) + , Bar (..) + , Baz + ) +where + +import Prelude (Eq, Ord) + +data Foo = Foo1 | Foo2 + deriving (Eq, Ord) + +data Bar = Bar1 | Bar2 | Bar3 + deriving (Eq, Ord) + +class Baz t +instance Baz Foo +instance Baz Bar diff --git a/test/info-util/info-util.cabal b/test/info-util/info-util.cabal new file mode 100644 --- /dev/null +++ b/test/info-util/info-util.cabal @@ -0,0 +1,18 @@ +name: info-util +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + InfoUtil + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports diff --git a/test/testdata/T21.expected.hs b/test/testdata/T21.expected.hs deleted file mode 100644 --- a/test/testdata/T21.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -module T21 where -import Data.Proxy (Proxy(..)) -import GHC.TypeNats (KnownNat) -import Type.Reflection (Typeable) - -fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) - => Proxy k -> Proxy n -> Proxy a -> () -fun _ _ _ = () - --- >>> :type fun --- fun --- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). --- (KnownNat k2, KnownNat n, Typeable a) => --- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/T21.hs b/test/testdata/T21.hs --- a/test/testdata/T21.hs +++ b/test/testdata/T21.hs @@ -9,4 +9,3 @@ => Proxy k -> Proxy n -> Proxy a -> () fun _ _ _ = () --- >>> :type fun diff --git a/test/testdata/T23.expected.hs b/test/testdata/T23.expected.hs deleted file mode 100644 --- a/test/testdata/T23.expected.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -module T23 where -import Data.Proxy (Proxy (..)) -import GHC.TypeNats (KnownNat) -import Type.Reflection (Typeable) - -f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) - => Proxy k -> Proxy n -> Proxy a -> () -f _ _ _ = () - --- >>> :type f --- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). --- (KnownNat k2, KnownNat n, Typeable a) => --- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/T23.hs b/test/testdata/T23.hs --- a/test/testdata/T23.hs +++ b/test/testdata/T23.hs @@ -9,4 +9,3 @@ => Proxy k -> Proxy n -> Proxy a -> () f _ _ _ = () --- >>> :type f diff --git a/test/testdata/T8.expected.hs b/test/testdata/T8.expected.hs deleted file mode 100644 --- a/test/testdata/T8.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Semantic and Lexical errors are reported -module T8 where - --- >>> noFunctionWithThisName --- Variable not in scope: noFunctionWithThisName - --- >>> "a" + "bc" --- No instance for (Num [Char]) arising from a use of ‘+’ - --- >>> " --- lexical error in string/character literal at end of input - --- >>> 3 `div` 0 --- divide by zero diff --git a/test/testdata/T8.hs b/test/testdata/T8.hs --- a/test/testdata/T8.hs +++ b/test/testdata/T8.hs @@ -1,10 +1,2 @@ --- Semantic and Lexical errors are reported +-- An empty playground module T8 where - --- >>> noFunctionWithThisName - --- >>> "a" + "bc" - --- >>> " - --- >>> 3 `div` 0 diff --git a/test/testdata/TFlags.expected.hs b/test/testdata/TFlags.expected.hs --- a/test/testdata/TFlags.expected.hs +++ b/test/testdata/TFlags.expected.hs @@ -49,18 +49,7 @@ -} -{- -fprint-* families ->>> import Data.Proxy ->>> :set -XPolyKinds ->>> :t Proxy -Proxy :: forall k (t :: k). Proxy t - ->>> :set -fprint-explicit-foralls ->>> :t Proxy -Proxy :: forall {k} {t :: k}. Proxy t --} - {- Invalid option/flags are reported, but valid ones will be reflected >>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all @@ -68,9 +57,4 @@ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all -Still, Rank2Types is enabled, as in GHCi: - ->>> f = const 42 :: (forall x. x) -> Int ->>> f undefined -42 -} diff --git a/test/testdata/TFlags.hs b/test/testdata/TFlags.hs --- a/test/testdata/TFlags.hs +++ b/test/testdata/TFlags.hs @@ -45,24 +45,9 @@ -} -{- -fprint-* families ->>> import Data.Proxy ->>> :set -XPolyKinds ->>> :t Proxy -Proxy :: forall k (t :: k). Proxy t - ->>> :set -fprint-explicit-foralls ->>> :t Proxy -Proxy :: forall {k} {t :: k}. Proxy t --} - {- Invalid option/flags are reported, but valid ones will be reflected >>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all -Still, Rank2Types is enabled, as in GHCi: - ->>> f = const 42 :: (forall x. x) -> Int ->>> f undefined -} diff --git a/test/testdata/TI_Info.hs b/test/testdata/TI_Info.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TI_Info.hs @@ -0,0 +1,5 @@ +module TI_Info (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :i Foo diff --git a/test/testdata/TInfo.hs b/test/testdata/TInfo.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInfo.hs @@ -0,0 +1,5 @@ +module TInfo (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info Foo diff --git a/test/testdata/TInfoBang.hs b/test/testdata/TInfoBang.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInfoBang.hs @@ -0,0 +1,5 @@ +module TInfoBang (Eq, Ord, Foo) where + +import InfoUtil (Eq, Ord, Foo) + +-- >>> :info! Foo diff --git a/test/testdata/TInfoBangMany.hs b/test/testdata/TInfoBangMany.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInfoBangMany.hs @@ -0,0 +1,5 @@ +module TInfoBangMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info! Foo Bar diff --git a/test/testdata/TInfoMany.hs b/test/testdata/TInfoMany.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TInfoMany.hs @@ -0,0 +1,5 @@ +module TInfoMany (Eq, Ord, Foo, Bar) where + +import InfoUtil (Eq, Ord, Foo, Bar) + +-- >>> :info Foo Bar diff --git a/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs b/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs @@ -0,0 +1,27 @@ +-- The default language extensions for the eval plugin are the same as those for ghci + +module TSameDefaultLanguageExtensionsAsGhci where + +{- +Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation. + +The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci. +(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483) + +It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only. +-} + + +-- ExtendedDefaultRules + +-- >>> [] +-- [] + +-- >>> reverse [] +-- [] + +-- NoMonomorphismRestriction + +-- >>> plus = (+) +-- >>> :t plus +-- plus :: Num a => a -> a -> a diff --git a/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs b/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs @@ -0,0 +1,24 @@ +-- The default language extensions for the eval plugin are the same as those for ghci + +module TSameDefaultLanguageExtensionsAsGhci where + +{- +Running `:showi language` within ghci currently lists NoDatatypeContexts, ExtendedDefaultRules, NoMonomorphismRestriction and NondecreasingIndentation. + +The flags NoDatatypeContexts and NondecreasingIndentation are globally set in Haskell2021, whereas ExtendedDefaultRules and NoMonomorphismRestriction are set manually within ghci. +(see https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483) + +It therefore suffices to test for ExtendedDefaultRules and NoMonomorphismRestriction only. +-} + + +-- ExtendedDefaultRules + +-- >>> [] + +-- >>> reverse [] + +-- NoMonomorphismRestriction + +-- >>> plus = (+) +-- >>> :t plus diff --git a/test/testdata/cabal.project b/test/testdata/cabal.project deleted file mode 100644 --- a/test/testdata/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./ diff --git a/test/testdata/test.cabal b/test/testdata/test.cabal --- a/test/testdata/test.cabal +++ b/test/testdata/test.cabal @@ -50,14 +50,19 @@ TLanguageOptionsTupleSections TIO TProperty + TSameDefaultLanguageExtensionsAsGhci TPrelude TCPP TLHS TSetup Util TNested + TInfo + TInfoMany + TInfoBang + TInfoBangMany + TI_Info - build-depends: base >= 4.7 && < 5, QuickCheck + build-depends: base >= 4.7 && < 5, QuickCheck, info-util default-language: Haskell2010 ghc-options: -Wall -fwarn-unused-imports -