tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Spec-fragments.hs (2351B)

      1 -- Historical SCP test fragments, not a standalone module.
      2 main :: IO ()
      3 main = do
      4   effectFixtures <- lookupEnv "TRICU_SCP_FIXTURE_TESTS"
      5   defaultMain $ if effectFixtures == Just "1" then scpEffectFixtures else tests
      6 
      7 -- Opt-in: preserve the old assertions, but load every library from the full
      8 -- fingerprinted portable fixture. Only the ordinary test wrapper is host-built.
      9 scpEffectFixtures :: TestTree
     10 scpEffectFixtures = localOption (NumThreads 1) $ testGroup "Stored-library SCP effects"
     11   [ testCase name $ withSystemTempDirectory "scp-effect-output" $ \dir ->
     12       withFile (dir </> "stdout") ReadWriteMode $ \handle -> do
     13         env <- evaluateCompilerFile ("./test/consumer_effect_" ++ name ++ ".tri")
     14         code <- maybe (assertFailure "missing main" >> pure Leaf) pure (Map.lookup "main" env)
     15         saved <- hDuplicate stdout
     16         outcome <- bracket (hDuplicateTo handle stdout >> pure saved)
     17           (\original -> hFlush stdout >> hDuplicateTo original stdout >> hClose original)
     18           (\_ -> Timeout.timeout (180 * 1000000) (runIO unsafePerms code))
     19         hSeek handle AbsoluteSeek 0
     20         output <- hGetContents handle
     21         _ <- evaluate (length output)
     22         assertBool (name ++ " output: " ++ output)
     23           (("consumer-effect-" ++ name ++ "-ok") `elem` lines output)
     24         case outcome of
     25           Just (Right _) -> pure ()
     26           _ -> assertFailure (name ++ " failed or exceeded 180 seconds")
     27   | name <- ["compose", "scopes", "results"] ]
     28 
     29   , testCase "SCP shared header keeps qualified defaults and body coordinates" $ do
     30       env <- compiledModuleEnv "consumers.unit-build"
     31       let header = "-- lead\r\n!import base\n!export main\n"
     32           body = "consumer main\n _ @ _ => Missing.code"
     33           outcome = apply (env Map.! "scpUnitStage") (ofString (header ++ body))
     34           staged = apply (env Map.! "fst") (apply (env Map.! "snd") outcome)
     35           masked = apply (env Map.! "snd") (apply (env Map.! "snd") (apply (env Map.! "snd") staged))
     36       apply (env Map.! "fst") outcome @?= Stem Leaf
     37       masked @?= ofString (map (\c -> if c == '\n' || c == '\r' then c else ' ') header ++ body)
     38       forM_ ["!import base *\n", "!import base as Self\n", "!import base as A.B\n"] $ \source ->
     39         apply (env Map.! "fst") (apply (env Map.! "scpUnitStage") (ofString source)) @?= Leaf