urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-11-24 13:06:09 +03:00
Code Issues Packages Projects Releases Wiki Activity

king: handle tanks that are just a cord.

Browse Source
This commit is contained in:
~siprel 2020-06-10 20:04:09 +00:00
parent e178ad353d
commit b552149610
2 changed files with 24 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -112,7 +112,9 @@ writeJobs log !jobs = do
-- Acquire a running serf. -----------------------------------------------------
printTank :: (Text -> IO ()) -> Atom -> Tank -> IO ()
printTank f _priority = f . unlines . fmap unTape . wash (WashCfg 0 80)
printTank f _priority = f . unlines . fmap unTape . wash (WashCfg 0 80) . tankTree
where
tankTree (Tank t) = t
runSerf
:: HasLogFunc e
@ -219,6 +221,7 @@ resumed vSlog replayUntil flags = do
Right _ -> do
logDebug "Taking snapshot"
io (Serf.snapshot serf)
logDebug "SNAPSHOT TAKEN"
pure (serf, log)

26
pkg/hs/urbit-noun/lib/Urbit/Noun/Tank.hs
View File

@ -7,18 +7,32 @@ module Urbit.Noun.Tank where
import ClassyPrelude
import Urbit.Noun.Conversions
import Urbit.Noun.TH
import Urbit.Noun.Convert
import Urbit.Noun.Core
--------------------------------------------------------------------------------
type Tang = [Tank]
data Tank
data TankTree
= Leaf Tape
| Plum Plum
| Palm (Tape, Tape, Tape, Tape) [Tank]
| Rose (Tape, Tape, Tape) [Tank]
| Palm (Tape, Tape, Tape, Tape) [TankTree]
| Rose (Tape, Tape, Tape) [TankTree]
deriving (Eq, Ord, Show)
newtype Tank = Tank { tankTree :: TankTree }
deriving newtype (Eq, Ord, Show)
instance ToNoun Tank where
toNoun (Tank t) = toNoun t
instance FromNoun Tank where
parseNoun n@(Atom _) = do
Cord txt <- parseNoun n
pure $ Tank $ Leaf $ Tape txt
parseNoun n = Tank <$> parseNoun n
data WideFmt = WideFmt { delimit :: Cord, enclose :: Maybe (Cord, Cord) }
deriving (Eq, Ord, Show)
@ -39,7 +53,7 @@ data PlumTree
deriveNoun ''WideFmt
deriveNoun ''TallFmt
deriveNoun ''PlumFmt
deriveNoun ''Tank
deriveNoun ''TankTree
deriveNoun ''PlumTree
--------------------------------------------------------------------------------
@ -51,7 +65,7 @@ data WashCfg = WashCfg
--------------------------------------------------------------------------------
wash :: WashCfg -> Tank -> Wall
wash :: WashCfg -> TankTree -> Wall
wash _cfg t = [ram t]
-- win :: WashCfg -> Tank -> Wall
@ -60,7 +74,7 @@ wash _cfg t = [ram t]
flat :: Plum -> Tape
flat = Tape . tshow
ram :: Tank -> Tape
ram :: TankTree -> Tape
ram = \case
Leaf tape -> tape
Plum plum -> flat plum