summaryrefslogtreecommitdiff
path: root/tests/TestPsci/TestEnv.hs
blob: 8f71d9ad01df5b1330279aa144688a475e4bc8ce (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
module TestPsci.TestEnv where

import Prelude ()
import Prelude.Compat

import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.RWS.Strict (evalRWST, RWST)
import qualified Language.PureScript as P
import           Language.PureScript.Interactive
import           System.Directory (getCurrentDirectory)
import           System.Exit
import           System.FilePath ((</>))
import qualified System.FilePath.Glob as Glob
import           System.Process (readProcessWithExitCode)
import           Test.Hspec (shouldBe)

-- | A monad transformer for handle PSCi actions in tests
type TestPSCi a = RWST PSCiConfig () PSCiState IO a

-- | Initialise PSCi state and config for tests
initTestPSCiEnv :: IO (PSCiState, PSCiConfig)
initTestPSCiEnv = do
  -- Load test support packages
  cwd <- getCurrentDirectory
  let supportDir = cwd </> "tests" </> "support" </> "bower_components"
  let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir
  pursFiles <- supportFiles "purs"
  modulesOrError <- loadAllModules pursFiles
  case modulesOrError of
    Left err ->
      print err >> exitFailure
    Right modules -> do
      -- Make modules
      makeResultOrError <- runMake . make $ modules
      case makeResultOrError of
        Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
        Right (externs, env) ->
          return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env)

-- | Execute a TestPSCi, returning IO
execTestPSCi :: TestPSCi a -> IO a
execTestPSCi i = do
  (s, c) <- initTestPSCiEnv -- init state and config
  fst <$> evalRWST i c s

-- | Evaluate JS to which a PSCi input is compiled. The actual JS input is not
-- needed as an argument, as it is already written in the file during the
-- command evaluation.
jsEval :: TestPSCi String
jsEval = liftIO $ do
  writeFile indexFile "require('$PSCI')['$main']();"
  process <- findNodeProcess
  result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process
  case result of
    Just (ExitSuccess, out, _)   -> return out
    Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure
    Nothing                      -> putStrLn "Couldn't find node.js" >> exitFailure

-- | Run a PSCi command and evaluate the output with 'eval'.
runAndEval :: String -> TestPSCi () -> TestPSCi ()
runAndEval comm eval =
  case parseCommand comm of
    Left errStr -> liftIO $ putStrLn errStr >> exitFailure
    Right command ->
      -- the JS result can be ignored, as it's already written in a source file
      -- for the detail, please refer to Interactive.hs
      handleCommand (\_ -> eval) (return ()) (\_ -> return ()) command

-- | Run a PSCi command and ignore the output
run :: String -> TestPSCi ()
run comm = runAndEval comm $ jsEval *> return ()

-- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi
equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi ()
equalsTo x y = liftIO $ x `shouldBe` y

-- | An assertion to check if a command evaluates to a string
evaluatesTo :: String -> String -> TestPSCi ()
evaluatesTo command expected = runAndEval command $ do
  actual <- jsEval
  actual `equalsTo` (expected ++ "\n")