hls-eval-plugin 1.1.1.0 → 1.1.2.0
raw patch · 24 files changed
+386/−155 lines, 24 filesdep ~ghc-api-compatdep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc-api-compat, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
Files
- hls-eval-plugin.cabal +23/−5
- src/Ide/Plugin/Eval/Code.hs +1/−11
- src/Ide/Plugin/Eval/CodeLens.hs +126/−36
- test/Main.hs +111/−13
- test/cabal.project +3/−0
- test/info-util/InfoUtil.hs +20/−0
- test/info-util/info-util.cabal +18/−0
- test/testdata/T21.expected.hs +0/−16
- test/testdata/T21.hs +0/−1
- test/testdata/T23.expected.hs +0/−15
- test/testdata/T23.hs +0/−1
- test/testdata/T8.expected.hs +0/−14
- test/testdata/T8.hs +1/−9
- test/testdata/TFlags.expected.hs +0/−16
- test/testdata/TFlags.hs +0/−15
- test/testdata/TI_Info.hs +5/−0
- test/testdata/TInfo.hs +5/−0
- test/testdata/TInfoBang.hs +5/−0
- test/testdata/TInfoBangMany.hs +5/−0
- test/testdata/TInfoMany.hs +5/−0
- test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs +27/−0
- test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs +24/−0
- test/testdata/cabal.project +0/−1
- test/testdata/test.cabal +7/−2
hls-eval-plugin.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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
src/Ide/Plugin/Eval/Code.hs view
@@ -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 ()
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -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 "<interactive>") 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 = "<interactive>"+#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
test/Main.hs view
@@ -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)
+ test/cabal.project view
@@ -0,0 +1,3 @@+packages:+ testdata/+ info-util/
+ test/info-util/InfoUtil.hs view
@@ -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
+ test/info-util/info-util.cabal view
@@ -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
− test/testdata/T21.expected.hs
@@ -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 -> ()
test/testdata/T21.hs view
@@ -9,4 +9,3 @@ => Proxy k -> Proxy n -> Proxy a -> () fun _ _ _ = () --- >>> :type fun
− test/testdata/T23.expected.hs
@@ -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 -> ()
test/testdata/T23.hs view
@@ -9,4 +9,3 @@ => Proxy k -> Proxy n -> Proxy a -> () f _ _ _ = () --- >>> :type f
− test/testdata/T8.expected.hs
@@ -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
test/testdata/T8.hs view
@@ -1,10 +1,2 @@--- Semantic and Lexical errors are reported+-- An empty playground module T8 where---- >>> noFunctionWithThisName---- >>> "a" + "bc"---- >>> "---- >>> 3 `div` 0
test/testdata/TFlags.expected.hs view
@@ -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 -}
test/testdata/TFlags.hs view
@@ -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 -}
+ test/testdata/TI_Info.hs view
@@ -0,0 +1,5 @@+module TI_Info (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :i Foo
+ test/testdata/TInfo.hs view
@@ -0,0 +1,5 @@+module TInfo (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :info Foo
+ test/testdata/TInfoBang.hs view
@@ -0,0 +1,5 @@+module TInfoBang (Eq, Ord, Foo) where++import InfoUtil (Eq, Ord, Foo)++-- >>> :info! Foo
+ test/testdata/TInfoBangMany.hs view
@@ -0,0 +1,5 @@+module TInfoBangMany (Eq, Ord, Foo, Bar) where++import InfoUtil (Eq, Ord, Foo, Bar)++-- >>> :info! Foo Bar
+ test/testdata/TInfoMany.hs view
@@ -0,0 +1,5 @@+module TInfoMany (Eq, Ord, Foo, Bar) where++import InfoUtil (Eq, Ord, Foo, Bar)++-- >>> :info Foo Bar
+ test/testdata/TSameDefaultLanguageExtensionsAsGhci.expected.hs view
@@ -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
+ test/testdata/TSameDefaultLanguageExtensionsAsGhci.hs view
@@ -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
− test/testdata/cabal.project
@@ -1,1 +0,0 @@-packages: ./
test/testdata/test.cabal view
@@ -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-