Got tests working again.

pkg/king/test/AmesTests.hs

@@ -1,7 +1,6 @@
 module AmesTests (tests) where
 
 import Arvo
-import Data.Acquire
 import Data.Conduit
 import Data.Conduit.List     hiding (take)
 import Data.Ord.Unicode
@@ -16,9 +15,10 @@ import Vere.Ames
 import Vere.Log
 import Vere.Pier.Types
 
-import Control.Concurrent (runInBoundThread, threadDelay)
+import Control.Concurrent (runInBoundThread)
 import Data.LargeWord     (LargeKey(..))
 import GHC.Natural        (Natural)
+import KingApp            (runApp)
 import Network.Socket     (tupleToHostAddress)
 
 import qualified Vere.Log as Log
@@ -35,11 +35,12 @@ turfEf = NewtEfTurf (0, ()) []
 sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
 sendEf g w bs = NewtEfSend (0, ()) (ADGala w g) bs
 
-runGala :: Word8 -> Acquire (TQueue Ev, EffCb NewtEf)
+runGala :: Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
 runGala point = do
-    q  <- liftIO newTQueueIO
-    cb <- snd $ ames pid (fromIntegral point) Nothing (writeTQueue q)
-    liftIO $ cb turfEf
+    q  <- newTQueueIO
+    let (_, runAmes) = ames pid (fromIntegral point) Nothing (writeTQueue q)
+    cb ← liftAcquire runAmes
+    rio $ cb turfEf
     pure (q, cb)
 
 waitForPacket :: TQueue Ev -> Bytes -> IO Bool
@@ -51,37 +52,37 @@ waitForPacket q val = go
         EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val)
         _                                        -> pure False
 
-runAcquire :: Acquire a -> IO a
-runAcquire acq = with acq pure
+runRAcquire :: RAcquire e a -> RIO e a
+runRAcquire acq = rwith acq pure
 
-sendThread :: EffCb NewtEf -> (Galaxy, Bytes) -> Acquire ()
-sendThread cb (to, val) = void $ mkAcquire start cancel
+sendThread :: EffCb e NewtEf -> (Galaxy, Bytes) -> RAcquire e ()
+sendThread cb (to, val) = void $ mkRAcquire start cancel
   where
     start = async $ forever $ do threadDelay 1_000
-                                 wen <- now
+                                 wen <- io $ now
                                  cb (sendEf to wen val)
                                  threadDelay 10_000
 
 zodSelfMsg :: Property
-zodSelfMsg = forAll arbitrary (ioProperty . runTest)
+zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: Bytes -> IO Bool
-    runTest val = runAcquire $ do
+    runTest :: Bytes -> RIO e Bool
+    runTest val = runRAcquire $ do
       (zodQ, zod) <- runGala 0
       ()          <- sendThread zod (0, val)
       liftIO (waitForPacket zodQ val)
 
 twoTalk :: Property
-twoTalk = forAll arbitrary (ioProperty . runTest)
+twoTalk = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: (Word8, Word8, Bytes) -> IO Bool
+    runTest :: (Word8, Word8, Bytes) -> RIO e Bool
     runTest (aliceShip, bobShip, val) =
       if aliceShip == bobShip
         then pure True
         else go aliceShip bobShip val
 
-    go :: Word8 -> Word8 -> Bytes -> IO Bool
-    go aliceShip bobShip val = runAcquire $ do
+    go :: Word8 -> Word8 -> Bytes -> RIO e Bool
+    go aliceShip bobShip val = runRAcquire $ do
         (aliceQ, alice) <- runGala aliceShip
         (bobQ,   bob)   <- runGala bobShip
         sendThread alice (Galaxy bobShip,   val)
@@ -129,6 +130,15 @@ genIpv4 = do
     then genIpv4
     else pure (Ipv4 x)
 
+instance Arbitrary Text where
+  arbitrary = pack <$> arb
+
+instance Arbitrary Cord where
+  arbitrary = Cord <$> arb
+
+instance Arbitrary BigCord where
+  arbitrary = BigCord <$> arb
+
 instance Arbitrary AmesDest where
   arbitrary = oneof [ ADGala <$> arb <*> arb
                     , ADIpv4 <$> arb <*> arb <*> genIpv4

pkg/king/test/ArvoTests.hs

@@ -155,6 +155,10 @@ instance Arbitrary StdMethod where
 instance Arbitrary Header where
   arbitrary = Header <$> arb <*> arb
 
+instance Arbitrary BigCord where
+  arbitrary = BigCord <$> arb
+
+
 instance Arbitrary ServId where arbitrary = ServId <$> arb
 
 instance Arbitrary UD where arbitrary = UD <$> arb

pkg/king/test/BehnTests.hs

@@ -19,6 +19,7 @@ import Vere.Pier.Types
 import Control.Concurrent (runInBoundThread, threadDelay)
 import Data.LargeWord     (LargeKey(..))
 import GHC.Natural        (Natural)
+import KingApp            (runApp)
 import Network.Socket     (tupleToHostAddress)
 
 import qualified Urbit.Time as Time
@@ -32,12 +33,12 @@ king = KingId 0
 
 -- TODO Timers always fire immediatly. Something is wrong!
 timerFires :: Property
-timerFires = forAll arbitrary (ioProperty . runTest)
+timerFires = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: () -> IO Bool
+    runTest :: () -> RIO e Bool
     runTest () = do
       q <- newTQueueIO
-      with (snd $ behn king (writeTQueue q)) $ \cb -> do
+      rwith (liftAcquire $ snd $ behn king (writeTQueue q)) $ \cb -> do
         cb (BehnEfDoze (king, ()) (Just (2^20)))
         t <- atomically $ readTQueue q
         print t

pkg/king/test/LogTests.hs

@@ -11,16 +11,17 @@ import Vere.Pier.Types
 import Data.Conduit
 import Data.Conduit.List hiding (filter)
 
-import Control.Concurrent (threadDelay, runInBoundThread)
+import Control.Concurrent (runInBoundThread, threadDelay)
 import Data.LargeWord     (LargeKey(..))
 import GHC.Natural        (Natural)
+import KingApp            (runApp, App)
 
 import qualified Vere.Log as Log
 
 
 -- Utils -----------------------------------------------------------------------
 
-withTestDir :: (FilePath -> IO a) -> IO a
+withTestDir :: (FilePath -> RIO e a) -> RIO e a
 withTestDir = withTempDirectory "./" ".testlog."
 
 data NotEqual = NotEqual String String
@@ -28,10 +29,9 @@ data NotEqual = NotEqual String String
 
 instance Exception NotEqual where
 
-assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual :: MonadIO m => (Show a, Eq a) => a -> a -> m ()
 assertEqual x y = do
-    unless (x == y) $
-        throwIO (NotEqual (show x) (show y))
+    unless (x == y) $ io $ throwIO $ NotEqual (show x) (show y)
 
 
 -- Database Operations ---------------------------------------------------------
@@ -42,15 +42,15 @@ data Db = Db LogIdentity [ByteString] (Map Word64 ByteString)
 addEvents :: Db -> [ByteString] -> Db
 addEvents (Db id evs efs) new = Db id (evs <> new) efs
 
-readDb :: EventLog -> IO Db
+readDb :: EventLog -> RIO App Db
 readDb log = do
     events  <- runConduit (streamEvents log 1 .| consume)
     effects <- runConduit (streamEffectsRows log 0 .| consume)
     pure $ Db (Log.identity log) events (mapFromList effects)
 
-withDb :: FilePath -> Db -> (EventLog -> IO a) -> IO a
+withDb :: FilePath -> Db -> (EventLog -> RIO App a) -> RIO App a
 withDb dir (Db dId dEvs dFx) act = do
-    with (Log.new dir dId) $ \log -> do
+    rwith (Log.new dir dId) $ \log -> do
         Log.appendEvents log (fromList dEvs)
         for_ (mapToList dFx) $ \(k,v) ->
             Log.writeEffectsRow log k v
@@ -59,70 +59,75 @@ withDb dir (Db dId dEvs dFx) act = do
 --------------------------------------------------------------------------------
 
 tryReadIdentity :: Property
-tryReadIdentity = forAll arbitrary (ioProperty . runTest)
+tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: LogIdentity -> IO Bool
+    runTest :: LogIdentity -> RIO App Bool
     runTest ident = do
-        runInBoundThread $
+        env <- ask
+        io $ runInBoundThread $ runRIO env $
             withTestDir $ \dir -> do
-                with (Log.new dir ident) $ \log ->
+                rwith (Log.new dir ident) $ \log ->
                     assertEqual ident (Log.identity log)
-                with (Log.existing dir) $ \log ->
+                rwith (Log.existing dir) $ \log ->
                     assertEqual ident (Log.identity log)
-                with (Log.existing dir) $ \log ->
+                rwith (Log.existing dir) $ \log ->
                     assertEqual ident (Log.identity log)
         pure True
 
 tryReadDatabase :: Property
-tryReadDatabase = forAll arbitrary (ioProperty . runTest)
+tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: Db -> IO Bool
+    runTest :: Db -> RIO App Bool
     runTest db = do
-        runInBoundThread $
+        env <- ask
+        io $ runInBoundThread $ runRIO env $
             withTestDir $ \dir -> do
                 withDb dir db $ \log -> do
                     readDb log >>= assertEqual db
         pure True
 
 tryReadDatabaseFuzz :: Property
-tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runTest)
+tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: Db -> IO Bool
+    runTest :: Db -> RIO App Bool
     runTest db = do
-        runInBoundThread $
+        env <- ask
+        io $ runInBoundThread $ runRIO env $
             withTestDir $ \dir -> do
                 withDb dir db $ \log -> do
                     readDb log >>= assertEqual db
-                with (Log.existing dir) $ \log -> do
+                rwith (Log.existing dir) $ \log -> do
                     readDb log >>= assertEqual db
-                with (Log.existing dir) $ \log -> do
+                rwith (Log.existing dir) $ \log -> do
                     readDb log >>= assertEqual db
                     readDb log >>= assertEqual db
         pure True
 
 tryAppend :: Property
-tryAppend = forAll arbitrary (ioProperty . runTest)
+tryAppend = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: ([ByteString], Db) -> IO Bool
+    runTest :: ([ByteString], Db) -> RIO App Bool
     runTest (extra, db) = do
-        runInBoundThread $
+        env <- ask
+        io $ runInBoundThread $ runRIO env $
             withTestDir $ \dir -> do
                 db' <- pure (addEvents db extra)
                 withDb dir db $ \log -> do
                     readDb log >>= assertEqual db
                     Log.appendEvents log (fromList extra)
                     readDb log >>= assertEqual db'
-                with (Log.existing dir) $ \log -> do
+                rwith (Log.existing dir) $ \log -> do
                     readDb log >>= assertEqual db'
         pure True
 
 tryAppendHuge :: Property
-tryAppendHuge = forAll arbitrary (ioProperty . runTest)
+tryAppendHuge = forAll arbitrary (ioProperty . runApp . runTest)
   where
-    runTest :: ([ByteString], Db) -> IO Bool
+    runTest :: ([ByteString], Db) -> RIO App Bool
     runTest (extra, db) = do
-        runInBoundThread $ do
-            extra <- do b <- readFile "/home/benajmin/r/urbit/bin/brass.pill"
+        env <- ask
+        io $ runInBoundThread $ runRIO env $ do
+            extra <- do b <- readFile "./bin/brass.pill"
                         pure (extra <> [b] <> extra)
             withTestDir $ \dir -> do
                 db' <- pure (addEvents db extra)
@@ -130,7 +135,7 @@ tryAppendHuge = forAll arbitrary (ioProperty . runTest)
                     readDb log >>= assertEqual db
                     Log.appendEvents log (fromList extra)
                     readDb log >>= assertEqual db'
-                with (Log.existing dir) $ \log -> do
+                rwith (Log.existing dir) $ \log -> do
                     readDb log >>= assertEqual db'
         pure True
 

pkg/king/test/Main.hs

@@ -6,6 +6,7 @@ import Test.QuickCheck       hiding ((.&.))
 import Test.Tasty
 import Test.Tasty.QuickCheck
 import Test.Tasty.TH
+import RIO.Directory
 
 import System.Environment (setEnv)
 import Control.Concurrent (runInBoundThread)
@@ -18,11 +19,12 @@ import qualified BehnTests
 
 main :: IO ()
 main = do
-  setEnv "TASTY_NUM_THREADS" "1"
-  runInBoundThread $ defaultMain $ testGroup "Urbit"
-    [ DeriveNounTests.tests
-    , ArvoTests.tests
-    , AmesTests.tests
-    , LogTests.tests
-    , BehnTests.tests
-    ]
+    makeAbsolute "../.." >>= setCurrentDirectory
+    setEnv "TASTY_NUM_THREADS" "1"
+    runInBoundThread $ defaultMain $ testGroup "Urbit"
+        [ DeriveNounTests.tests
+        , ArvoTests.tests
+        , AmesTests.tests
+        , LogTests.tests
+        , BehnTests.tests
+        ]