tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

BoundaryTests.hs (2360B)

      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 -- Inject bottoms through the Haskell-side registry for boundary fault tests.
      3 module Main where
      4 import qualified EmbeddingCore as E
      5 import qualified Embedding as Host
      6 import Control.Monad (unless)
      7 import Control.Monad.IO.Class (liftIO)
      8 import Control.Concurrent
      9 import Runtime.Tree (T(..))
     10 import Runtime.Value (ofString, ofNumber)
     11 import Foreign
     12 import Data.Word
     13 import Control.Exception (evaluate)
     14 
     15 assert :: Bool -> IO ()
     16 assert ok = unless ok (fail "embedding boundary assertion failed")
     17 main :: IO ()
     18 main = alloca $ \ctxOut -> alloca $ \out -> do
     19   E.contextNew ctxOut >>= assert . (== 0)
     20   ctx <- peek ctxOut
     21   E.withContext ctx (E.publish out (error "boundary poison")) >>= assert . (== 0)
     22   poison <- peek out
     23   poke out 987
     24   E.reduce ctx poison out >>= assert . (== 5)
     25   peek out >>= assert . (== 987)
     26   -- Even application of a bottom function is suspended by the boundary.
     27   E.application ctx poison poison out >>= assert . (== 0)
     28   suspended <- peek out
     29   E.release ctx suspended >>= assert . (== 0)
     30   E.leaf ctx out >>= assert . (== 0)
     31   leaf <- peek out
     32   E.fork ctx leaf leaf out >>= assert . (== 0)
     33   constant <- peek out
     34   E.application ctx constant poison out >>= assert . (== 0)
     35   discarded <- peek out
     36   E.reduce ctx discarded out >>= assert . (== 0)
     37   value <- peek out
     38   E.toU64 ctx value out >>= assert . (== 0)
     39   peek out >>= assert . (== (0 :: Word64))
     40 
     41   -- Terminal task diagnostics remain opaque across the native boundary.
     42   E.withContext ctx (E.publish out
     43     (Fork (ofString "tricuIO") (Fork (ofNumber 2)
     44       (Fork (ofNumber 2) (error "opaque diagnostic"))))) >>= assert . (== 0)
     45   program <- peek out
     46   alloca $ \tag -> alloca $ \reason -> alloca $ \cleanup -> do
     47     Host.runIO ctx program tag reason cleanup >>= assert . (== 0)
     48     peek tag >>= assert . (== 1)
     49     failed <- peek reason
     50     E.reduce ctx failed out >>= assert . (== 5)
     51   -- An interrupted call restores the context lock and contains its exception.
     52   entered <- newEmptyMVar
     53   done <- newEmptyMVar
     54   thread <- forkIO $ E.withContext ctx (do
     55     liftIO (putMVar entered () >> threadDelay 10000000)
     56     pure (pure ())) >>= putMVar done
     57   takeMVar entered
     58   killThread thread
     59   takeMVar done >>= assert . (== 5)
     60   E.leaf ctx out >>= assert . (== 0)
     61   E.contextFree ctx >>= assert . (== 0)
     62   _ <- evaluate poison
     63   pure ()