{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} module Main ( main ) where import Control.Lens (_Just, folded, preview, view, (^.), (^..)) import Data.Aeson (Value (Object), fromJSON, object, (.=)) import Data.Aeson.Types (Pair, Result (Success)) import Data.List (isInfixOf) import Data.List.Extra (nubOrdOn) import qualified Data.Map as Map import Data.Row import qualified Data.Text as T import Ide.Plugin.Config (Config) import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) import Language.LSP.Protocol.Lens (command, range, title) import System.FilePath ((<.>), ()) import Test.Hls import qualified Test.Hls.FileSystem as FS main :: IO () main = defaultTestRunner tests evalPlugin :: PluginTestDescriptor Eval.Log evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval" tests :: TestTree tests = testGroup "eval" [ testCase "Produces Evaluate code lenses" $ runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] , testCase "Produces Refresh code lenses" $ runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] , testCase "Code lenses have ranges" $ runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T1.hs") $ do doc <- openDoc "T1.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , testCase "Multi-line expressions have a multi-line range" $ do runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T3.hs") $ do doc <- openDoc "T3.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] , testCase "Executed expressions range covers only the expression" $ do runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject "T2.hs") $ do doc <- openDoc "T2.hs" "haskell" lenses <- getCodeLenses doc liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] , goldenWithEval "Evaluation of expressions" "T1" "hs" , goldenWithEval "Reevaluation of expressions" "T2" "hs" , goldenWithEval "Evaluation of expressions w/ imports" "T3" "hs" , goldenWithEval "Evaluation of expressions w/ lets" "T4" "hs" , goldenWithEval "Refresh an evaluation" "T5" "hs" , goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs" , goldenWithEval "Refresh a multiline evaluation" "T7" "hs" , goldenWithEval "Evaluate a multi-line show result" "TMultiResult" "hs" -- Do not escape from comments! , testCase "Semantic and Lexical errors are reported" $ do evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ if | ghcVersion >= GHC96 -> "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’" | otherwise -> "-- 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" -- The default for marking exceptions is False , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" ( if ghcVersion >= GHC94 then "ghc94.expected" else if ghcVersion >= GHC92 then "ghc92.expected" else "expected" ) , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069 , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" , 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" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , testCase ":type handles a multilined result properly" $ evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ "-- fun", if | ghcVersion >= GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." | otherwise -> "-- :: 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" , testCase ":type does \"dovetails\" for short identifiers" $ evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ if | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." | otherwise -> "-- 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" , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs" , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs" , goldenWithEval "Multi line comments" "TMulti" "hs" , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs" , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs" , goldenWithEval "Evaluate expressions in Haddock comments in both single line and multi line format" "THaddock" "hs" , goldenWithEval "Compare results (for Haddock tests only)" "TCompare" "hs" , goldenWithEvalAndFs "Local Modules imports are accessible in a test" (FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) "TLocalImport" "hs" , goldenWithEvalAndFs "Transitive local dependency" (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "TTransitive" "hs" -- , 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" (if ghcVersion >= GHC98 then "ghc98.expected" else if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , 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" (if ghcVersion >= GHC92 then "-- id :: forall a. a -> a" else "-- 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" , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" ( if ghcVersion >= GHC98 then "ghc98.expected" else if ghcVersion >= GHC96 then "ghc96.expected" else if ghcVersion >= GHC94 then "ghc94.expected" else "expected" ) , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" , 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] "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $ goldenWithEval "CPP support" "TCPP" "hs" , goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs" ] , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs" , goldenWithEval "Variable 'it' works" "TIt" "hs" , testGroup "configuration" [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default" , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False) , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True) ] , 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" ] , testCase "Interfaces are reused after Eval" $ do runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProjectMulti ["TLocalImport.hs", "Util.hs"]) $ do doc <- openDoc "TLocalImport.hs" "haskell" _ <- waitForTypecheck doc lenses <- getCodeLenses doc cmd <- liftIO $ case lenses^..folded.command._Just of [cmd] -> (cmd^.title @?= "Evaluate...") >> pure cmd cmds -> assertFailure $ "Expected a single command, got " <> show (length cmds) executeCmd cmd -- trigger a rebuild and check that dependency interfaces are not rebuilt changeDoc doc [] _ <- waitForTypecheck doc Right keys <- getLastBuildKeys let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys liftIO $ ifaceKeys @?= [] ] goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree goldenWithEvalAndFs title tree path ext = goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path "expected" ext executeLensesBackwards -- | Similar function as 'goldenWithEval' with an alternate reference file -- naming. Useful when reference file may change because of GHC version. goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEval' title path ext expected = goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path expected ext executeLensesBackwards goldenWithEvalAndFs' :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> FilePath -> TestTree goldenWithEvalAndFs' title tree path ext expected = goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) 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 -- Execute sequentially, nubbing elements to avoid -- evaluating the same section with multiple tests -- more than twice mapM_ executeCmd $ nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses] actSectionId :: Command -> Int actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId actSectionId _ = error "Invalid CodeLens" -- Execute command and wait for result executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd _ <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- liftIO $ print _resp pure () evalLenses :: FilePath -> IO [CodeLens] evalLenses path = runSessionWithServerInTmpDir def evalPlugin (mkFs cabalProjectFS) $ do doc <- openDoc path "haskell" executeLensesBackwards doc getCodeLenses doc codeLensTestOutput :: CodeLens -> [String] codeLensTestOutput codeLens = do CodeLens { _command = Just command } <- [codeLens] Command { _arguments = Just args } <- [command] Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args Section { sectionTests = sectionTests } <- sections testOutput =<< sectionTests testDataDir :: FilePath testDataDir = "plugins" "hls-eval-plugin" "test" "testdata" changeConfig :: [Pair] -> Config changeConfig conf = def { Plugin.plugins = Map.fromList [("eval", def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object conf } )] } where unObject (Object obj) = obj unObject _ = undefined diffOffConfig :: Config diffOffConfig = changeConfig ["diff" .= False] exceptionConfig :: Bool -> Config exceptionConfig exCfg = changeConfig ["exception" .= exCfg] goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree goldenWithEvalConfig' title path ext expected cfg = goldenWithHaskellDocInTmpDir cfg evalPlugin title (mkFs $ FS.directProject $ path <.> ext) path expected ext $ \doc -> do executeLensesBackwards doc evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO () evalInFile fp e expected = runSessionWithServerInTmpDir def evalPlugin (mkFs $ FS.directProject fp) $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval] executeLensesBackwards doc result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc liftIO $ result @?= Just (T.strip expected) -- ---------------------------------------------------------------------------- -- File system definitions -- Used for declaring a test file tree -- ---------------------------------------------------------------------------- mkFs :: [FS.FileTree] -> FS.VirtualFileTree mkFs = FS.mkVirtualFileTree testDataDir cabalProjectFS :: [FS.FileTree] cabalProjectFS = FS.simpleCabalProject' [ FS.copy "test.cabal" , FS.file "cabal.project" (FS.text "packages: ./info-util .\n" ) , FS.copy "TProperty.hs" , FS.copy "TPropertyError.hs" , FS.copy "TI_Info.hs" , FS.copy "TInfo.hs" , FS.copy "TInfoBang.hs" , FS.copy "TInfoBangMany.hs" , FS.copy "TInfoMany.hs" , FS.directory "info-util" [ FS.copy "info-util/info-util.cabal" , FS.copy "info-util/InfoUtil.hs" ] ]