diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index 1b9c7ab3f5..41c8a37c9c 100644 --- a/pkg/king/app/Main.hs +++ b/pkg/king/app/Main.hs @@ -432,7 +432,7 @@ runShip (CLI.Run pierPath) opts = do startBrowser :: HasLogFunc e => FilePath -> RIO e () startBrowser pierPath = runRAcquire $ do - lockFile pierPath + -- lockFile pierPath log <- Log.existing (pierPath <> "/.urb/log") rio $ EventBrowser.run log diff --git a/pkg/king/lib/Noun/Conversions.hs b/pkg/king/lib/Noun/Conversions.hs index 578209cfc9..609f185cff 100644 --- a/pkg/king/lib/Noun/Conversions.hs +++ b/pkg/king/lib/Noun/Conversions.hs @@ -686,36 +686,35 @@ instance FromNoun a => FromNoun (Maybe a) where unexpected s = fail ("Expected unit value, but got " <> s) -- Each is a direct translation of Hoon +each, preserving order - data Each a b = EachYes a | EachNo b deriving (Eq, Ord, Show) instance (ToNoun a, ToNoun b) => ToNoun (Each a b) where - toNoun (EachYes x) = Cell (Atom 0) (toNoun x) - toNoun (EachNo x) = Cell (Atom 1) (toNoun x) + toNoun (EachYes x) = C (A 0) (toNoun x) + toNoun (EachNo x) = C (A 1) (toNoun x) instance (FromNoun a, FromNoun b) => FromNoun (Each a b) where - parseNoun n = named "Each" $ do - (Atom tag, v) <- parseNoun n - case tag of - 0 -> named "%y" (EachYes <$> parseNoun v) - 1 -> named "%|" (EachNo <$> parseNoun v) - n -> fail ("Each has invalid head-atom: " <> show n) + parseNoun n = named "Each" $ do + (Atom tag, v) <- parseNoun n + case tag of + 0 -> named "&" (EachYes <$> parseNoun v) + 1 -> named "|" (EachNo <$> parseNoun v) + n -> fail ("Each has invalid head-atom: " <> show n) -- Tuple Conversions ----------------------------------------------------------- instance ToNoun () where - toNoun () = Atom 0 + toNoun () = Atom 0 instance FromNoun () where - parseNoun = named "()" . \case - Atom 0 -> pure () - x -> fail ("expecting `~`, but got " <> show x) + parseNoun = named "()" . \case + Atom 0 -> pure () + x -> fail ("expecting `~`, but got " <> show x) instance (ToNoun a, ToNoun b) => ToNoun (a, b) where - toNoun (x, y) = Cell (toNoun x) (toNoun y) + toNoun (x, y) = Cell (toNoun x) (toNoun y) shortRec :: Word -> Parser a diff --git a/pkg/king/lib/Vere/Log.hs b/pkg/king/lib/Vere/Log.hs index 28dbcae681..24818044f4 100644 --- a/pkg/king/lib/Vere/Log.hs +++ b/pkg/king/lib/Vere/Log.hs @@ -68,7 +68,7 @@ rawOpen :: MonadIO m => FilePath -> m Env rawOpen dir = io $ do env <- mdb_env_create mdb_env_set_maxdbs env 3 - mdb_env_set_mapsize env (40 * 1024 * 1024 * 1024) + mdb_env_set_mapsize env (100 * 1024 * 1024 * 1024) mdb_env_open env dir [] pure env diff --git a/pkg/king/lib/Vere/Serf.hs b/pkg/king/lib/Vere/Serf.hs index 9139008b52..f9f733ca80 100644 --- a/pkg/king/lib/Vere/Serf.hs +++ b/pkg/king/lib/Vere/Serf.hs @@ -60,7 +60,7 @@ data Config = Config FilePath [Flag] deriving (Show) serf :: HasLogFunc e => Text -> RIO e () -serf msg = logInfo $ display ("SERF: " <> msg) +serf msg = pure () -- logInfo $ display ("SERF: " <> msg) -- Types ----------------------------------------------------------------------- @@ -230,9 +230,9 @@ sendLen s i = do sendOrder :: HasLogFunc e => Serf e -> Order -> RIO e () sendOrder w o = do - logDebug $ display ("(sendOrder) " <> tshow o) + -- logDebug $ display ("(sendOrder) " <> tshow o) sendBytes w $ jamBS $ toNoun o - logDebug "(sendOrder) Done" + -- logDebug "(sendOrder) Done" sendBytes :: HasLogFunc e => Serf e -> ByteString -> RIO e () sendBytes s bs = handle ioErr $ do @@ -281,9 +281,9 @@ shutdown serf code = sendOrder serf (OExit code) -} recvPlea :: HasLogFunc e => Serf e -> RIO e Plea recvPlea w = do - logDebug "(recvPlea) Waiting" + -- logDebug "(recvPlea) Waiting" a <- recvAtom w - logDebug "(recvPlea) Got atom" + -- logDebug "(recvPlea) Got atom" n <- fromRightExn (cue a) (const $ BadPleaAtom a) p <- fromRightExn (fromNounErr n) (\(p,m) -> BadPleaNoun n p m) @@ -291,7 +291,7 @@ recvPlea w = do recvPlea w PSlog _ pri t -> do printTank (sStderr w) pri t recvPlea w - _ -> do logTrace "recvPlea got something else" + _ -> do -- logTrace "recvPlea got something else" pure p {- @@ -313,7 +313,7 @@ sendWork w job = do sendOrder w (OWork job) res <- loop - logTrace ("[sendWork] Got response") + -- logTrace ("[sendWork] Got response") pure res where eId = jobId job @@ -451,7 +451,7 @@ toJobs ident eId = await >>= \case Nothing -> lift $ logTrace "[toJobs] no more jobs" Just at -> do yield =<< lift (fromAtom at) - lift $ logTrace $ display ("[toJobs] " <> tshow eId) + -- lift $ logTrace $ display ("[toJobs] " <> tshow eId) toJobs ident (eId+1) where isNock = eId <= fromIntegral (lifecycleLen ident) @@ -497,7 +497,8 @@ doCollectFX serf = go Just jb -> do -- jb <- pure $ replaceMug jb (ssLastMug ss) (_, ss, fx) <- lift $ doJob serf jb - lift $ logTrace $ displayShow (jobId jb) + when (0 == (jobId jb `mod` 10_000)) $ do + lift $ logTrace $ displayShow (jobId jb) yield (jobId jb, fx) go ss