{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Main
( main
) where
import Control.Lens (_Just, folded, preview, toListOf,
view, (^..))
import Data.Aeson (Value (Object), fromJSON, object,
toJSON, (.=))
import Data.Aeson.Types (Pair, Result (Success))
import Data.List (isInfixOf)
import Data.List.Extra (nubOrdOn)
import qualified Data.Map as Map
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.Types.Lens (arguments, command, range, title)
import System.FilePath ((</>))
import Test.Hls
main :: IO ()
main = defaultTestRunner tests
evalPlugin :: PluginTestDescriptor Eval.Log
evalPlugin = mkPluginTestDescriptor Eval.descriptor "eval"
tests :: TestTree
tests =
testGroup "eval"
[ testCase "Produces Evaluate code lenses" $
runSessionWithServer evalPlugin testDataDir $ do
doc <- openDoc "T1.hs" "haskell"
lenses <- getCodeLenses doc
liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."]
, testCase "Produces Refresh code lenses" $
runSessionWithServer evalPlugin testDataDir $ do
doc <- openDoc "T2.hs" "haskell"
lenses <- getCodeLenses doc
liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."]
, testCase "Code lenses have ranges" $
runSessionWithServer evalPlugin testDataDir $ 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
runSessionWithServer evalPlugin testDataDir $ 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
runSessionWithServer evalPlugin testDataDir $ 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 == 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 == 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"
, knownBrokenForGhcVersions [GHC92] "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"
, goldenWithEval "local imports" "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"
, goldenWithEval "Local Modules imports are accessible in a test" "TLocalImport" "hs"
, goldenWithEval "Transitive local dependency" "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 == 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"
, goldenWithEval "Property checking" "TProperty" "hs"
, goldenWithEval "Property checking with exception" "TPropertyError" "hs"
, 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
runSessionWithServer evalPlugin testDataDir $ do
doc <- openDoc "TLocalImport.hs" "haskell"
waitForTypecheck doc
lenses <- getCodeLenses doc
let ~cmds@[cmd] = lenses^..folded.command._Just
liftIO $ cmds^..folded.title @?= ["Evaluate..."]
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 =
goldenWithHaskellDoc evalPlugin title testDataDir 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 =
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
-- 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 (List [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 SWorkspaceApplyEdit)
-- 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"
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 =
goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do
sendConfigurationChanged (toJSON cfg)
executeLensesBackwards doc
evalInFile :: HasCallStack => 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)