ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-15 01:52:42 +03:00
Code Issues Packages Projects Releases Wiki Activity

Lots of noun parsing/unparsing code.

Browse Source
This commit is contained in:
Benjamin Summers 2019-06-01 14:07:40 -07:00
parent 6a5bc78370
commit 5b3ab33dac
4 changed files with 204 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkg/hair/lib/Data/Noun/Jam.hs
View File

@ -3,7 +3,6 @@ module Data.Noun.Jam where
import ClassyPrelude
import Data.Noun
import Data.Noun.Atom
import Data.Noun.Poet
import Data.Bits
import Control.Lens
import Text.Printf
@ -79,7 +78,7 @@ cue' buf = view _2 <$> go mempty 0
go tbl i =
case (bitIdx i buf, bitIdx (i+1) buf) of
(False, _ ) -> do Buf wid at <- rub' (Cursor (i+1) buf)
let r = toNoun at
let r = Atom at
pure (wid+1, r, insertMap i r tbl)
(True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2)
(rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz)
@ -169,7 +168,7 @@ cue buf = view _2 <$> go mempty 0
-- trace ("go-" <> show i)
case (bitIdx i buf, bitIdx (i+1) buf) of
(False, _ ) -> do Buf wid at <- rub (Cursor (i+1) buf)
let r = toNoun at
let r = Atom at
pure (wid+1, r, insertMap i r tbl)
(True, False ) -> do (lSz,lef,tbl) <- go tbl (i+2)
(rSz,rit,tbl) <- go tbl (i+2+fromIntegral lSz)

181
pkg/hair/lib/Data/Noun/Poet.hs
View File

@ -1,22 +1,38 @@
module Data.Noun.Poet where
import Prelude
import ClassyPrelude hiding (fromList)
import Control.Lens
import Control.Applicative
import Control.Monad
import Data.Noun
import Data.Noun.Atom
import Data.Noun.Pill
import Data.Void
import Data.Word
import GHC.Natural
import Data.List (intercalate)
import Data.Typeable (Typeable)
import Data.Word (Word, Word32, Word64)
import qualified Control.Monad.Fail as Fail
-- Types For Hoon Constructs ---------------------------------------------------
{-|
`Nullable a <-> ?@(~ a)`
This is distinct from `unit`, since there is no tag on the non-atom
case, therefore `a` must always be cell type.
-}
data Nullable a = Nil | NotNil a
deriving (Eq, Ord, Show)
newtype Cord = Cord ByteString
deriving newtype (Eq, Ord, Show)
-- IResult ---------------------------------------------------------------------
data IResult a = IError NounPath String | ISuccess a
@ -169,7 +185,8 @@ instance ToNoun Noun where
instance FromNoun Noun where
parseNoun = pure
-- Bool Conversion -------------------------------------------------------------
-- Loobean Conversion ----------------------------------------------------------
instance ToNoun Bool where
toNoun True = Atom 0
@ -181,6 +198,7 @@ instance FromNoun Bool where
parseNoun (Cell _ _) = fail "expecting a bool, but got a cell"
parseNoun (Atom a) = fail ("expecting a bool, but got " <> show a)
-- Atom Conversion -------------------------------------------------------------
instance ToNoun Atom where
@ -190,42 +208,153 @@ instance FromNoun Atom where
parseNoun (Cell _ _) = fail "Expecting an atom, but got a cell"
parseNoun (Atom a) = pure a
-- Natural Conversion-----------------------------------------------------------
instance ToNoun Natural where toNoun = toNoun . MkAtom
instance FromNoun Natural where parseNoun = fmap unAtom . parseNoun
-- Word Conversion -------------------------------------------------------------
instance ToNoun Word where
toNoun = Atom . fromIntegral
atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a
atomToWord atom = do
if atom > fromIntegral (maxBound :: a)
then fail "Atom doesn't fit in fixed-size word"
else pure (fromIntegral atom)
instance ToNoun Word32 where
toNoun = Atom . fromIntegral
wordToNoun :: Integral a => a -> Noun
wordToNoun = Atom . fromIntegral
instance FromNoun Word32 where
parseNoun (Cell _ _) = fail "cell is not an atom"
parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow
nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
nounToWord = parseNoun >=> atomToWord
instance ToNoun Word64 where
toNoun = Atom . fromIntegral
instance ToNoun Word where toNoun = wordToNoun
instance ToNoun Word8 where toNoun = wordToNoun
instance ToNoun Word16 where toNoun = wordToNoun
instance ToNoun Word32 where toNoun = wordToNoun
instance ToNoun Word64 where toNoun = wordToNoun
instance FromNoun Word64 where
parseNoun (Cell _ _) = fail "cell is not an atom"
parseNoun (Atom a) = pure (fromIntegral a) -- TODO Overflow
instance ToNoun Natural where
toNoun = toNoun . toAtom
instance FromNoun Word where parseNoun = nounToWord
instance FromNoun Word8 where parseNoun = nounToWord
instance FromNoun Word16 where parseNoun = nounToWord
instance FromNoun Word32 where parseNoun = nounToWord
instance FromNoun Word64 where parseNoun = nounToWord
-- Cell Conversion -------------------------------------------------------------
-- Nullable Conversion ---------------------------------------------------------
-- TODO Consider enforcing that `a` must be a cell.
instance ToNoun a => ToNoun (Nullable a) where
toNoun Nil = Atom 0
toNoun (NotNil x) = toNoun x
instance FromNoun a => FromNoun (Nullable a) where
parseNoun (Atom 0) = pure Nil
parseNoun (Atom n) = fail ("Expected ?@(~ ^), but got " <> show n)
parseNoun n = NotNil <$> parseNoun n
-- Maybe is `unit` -------------------------------------------------------------
-- TODO Consider enforcing that `a` must be a cell.
instance ToNoun a => ToNoun (Maybe a) where
toNoun Nothing = Atom 0
toNoun (Just x) = Cell (Atom 0) (toNoun x)
instance FromNoun a => FromNoun (Maybe a) where
parseNoun = \case
Atom 0 -> pure Nothing
Atom n -> unexpected ("atom " <> show n)
Cell (Atom 0) t -> Just <$> parseNoun t
Cell n _ -> unexpected ("cell with head-atom " <> show n)
where
unexpected s = fail ("Expected unit value, but got " <> s)
-- List Conversion -------------------------------------------------------------
instance ToNoun a => ToNoun [a] where
toNoun xs = fromList (toNoun <$> xs)
instance FromNoun a => FromNoun [a] where
parseNoun (Atom 0) = pure []
parseNoun (Atom _) = fail "list terminated with non-null atom"
parseNoun (Cell l r) = (:) <$> parseNoun l <*> parseNoun r
-- Cord Conversion -------------------------------------------------------------
instance ToNoun Cord where
toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS))
instance FromNoun Cord where
parseNoun n = do
atom <- parseNoun n
pure $ Cord (atom ^. pill . pillBS)
-- Pair Conversion -------------------------------------------------------------
instance (ToNoun a, ToNoun b) => ToNoun (a, b) where
toNoun (x, y) = Cell (toNoun x) (toNoun y)
instance (FromNoun a, FromNoun b) => FromNoun (a, b) where
parseNoun (Atom n) = fail ("expected a cell, but got an atom: " <> show n)
parseNoun (Cell l r) = (,) <$> parseNoun l <*> parseNoun r
-- Trel Conversion -------------------------------------------------------------
instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where
toNoun (x, y, z) = Cell (toNoun x)
$ Cell (toNoun y) (toNoun z)
toNoun (x, y, z) = toNoun (x, (y, z))
instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where
parseNoun n = do
(x, t) <- parseNoun n
(y, z) <- parseNoun t
pure (x, y, z)
-- Quad Conversion -------------------------------------------------------------
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where
toNoun (x, y, z, a) = Cell (toNoun x)
$ Cell (toNoun y)
$ Cell (toNoun z) (toNoun a)
toNoun (p, q, r, s) = toNoun (p, (q, r, s))
instance ToNoun a => ToNoun [a] where
toNoun xs = fromList (toNoun <$> xs)
instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d)
=> FromNoun (a, b, c, d)
where
parseNoun n = do
(p, tail) <- parseNoun n
(q, r, s) <- parseNoun tail
pure (p, q, r, s)
-- Pent Conversion ------------------------------------------------------------
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e)
=> ToNoun (a, b, c, d, e) where
toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t))
instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e)
=> FromNoun (a, b, c, d, e)
where
parseNoun n = do
(p, tail) <- parseNoun n
(q, r, s, t) <- parseNoun tail
pure (p, q, r, s, t)
-- Sext Conversion ------------------------------------------------------------
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f)
=> ToNoun (a, b, c, d, e, f) where
toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u))
instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e,FromNoun f)
=> FromNoun (a, b, c, d, e, f)
where
parseNoun n = do
(p, tail) <- parseNoun n
(q, r, s, t, u) <- parseNoun tail
pure (p, q, r, s, t, u)

5
pkg/hair/lib/Vere/Isle.hs
View File

@ -21,6 +21,11 @@ data Color
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass Flat
type Blit = Vector (Vector Color)
solid :: Color -> Blit
solid c = replicate 640 (replicate 480 c)
toRGB :: Color -> (Word8, Word8, Word8)
toRGB = \case
Black -> (0x00, 0x00, 0x00)

94
pkg/hair/lib/Vere/Worker.hs
View File

@ -26,18 +26,6 @@ data Worker = Worker
-- , task :: Async ()
}
newtype Cord = Cord ByteString
deriving newtype (Eq, Ord, Show)
--------------------------------------------------------------------------------
instance ToNoun Cord where
toNoun (Cord bs) = Atom (bs ^. from (pill . pillBS))
instance FromNoun Cord where
parseNoun n = do
atom <- parseNoun n
pure $ Cord (atom ^. pill . pillBS)
--------------------------------------------------------------------------------
@ -58,35 +46,23 @@ kill w = do
work :: Word64 -> Jam -> Atom
work id (Jam a) = jam $ toNoun (Cord "work", id, a)
data Job = Job Void
deriving (Eq, Show)
newtype Job = Job Void
deriving newtype (Eq, Show, ToNoun, FromNoun)
data Tank = Tank Void
deriving (Eq, Show)
newtype Tank = Tank Void
deriving newtype (Eq, Show, ToNoun, FromNoun)
type EventId = Word64
newtype Ship = Ship Word64 -- @p
deriving newtype (Eq, Show, FromNoun, ToNoun)
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
data ShipId = ShipId { addr :: Ship, fake :: Bool }
deriving (Eq, Show)
newtype ShipId = ShipId (Ship, Bool)
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
--------------------------------------------------------------------------------
data Play
= PlayNone -- ~
| PlaySnap EventId Mug ShipId -- [@ @ @ ?]
deriving (Eq, Show)
instance ToNoun Play where
toNoun = \case PlayNone -> Atom 0
PlaySnap e m (ShipId a f) -> toNoun (e, m, a, f)
instance FromNoun Play where
parseNoun = undefined
--------------------------------------------------------------------------------
type Play = Nullable (EventId, Mug, ShipId)
data Plea
= Play Play
@ -96,8 +72,23 @@ data Plea
| Slog EventId Word32 Tank
deriving (Eq, Show)
instance ToNoun Plea where
toNoun = \case
Play p -> toNoun (Cord "play", p)
Work i m j -> toNoun (Cord "work", i, m, j)
Done i m o -> toNoun (Cord "done", i, m, o)
Stdr i msg -> toNoun (Cord "stdr", i, msg)
Slog i p t -> toNoun (Cord "slog", i, p, t)
instance FromNoun Plea where
parseNoun = undefined
parseNoun n =
parseNoun n >>= \case
(Cord "play", p) -> parseNoun p <&> \p -> Play p
(Cord "work", w) -> parseNoun w <&> \(i, m, j) -> Work i m j
(Cord "done", d) -> parseNoun d <&> \(i, m, o) -> Done i m o
(Cord "stdr", r) -> parseNoun r <&> \(i, msg) -> Stdr i msg
(Cord "slog", s) -> parseNoun s <&> \(i, p, t) -> Slog i p t
(Cord tag , s) -> fail ("Invalid plea tag: " <> unpack (decodeUtf8 tag))
--------------------------------------------------------------------------------
@ -186,26 +177,25 @@ replay w (wid, wmug) lastCommitedId getEvents = do
-- todo: these actually have to happen concurrently
computeThread :: Worker -> IO ()
computeThread w = start
where
start = do
Play p <- recvPlea w
let (eventId, mug) = playWorkerState p
-- fuck it, we'll do it liv_o
undefined
boot :: WorkerState -> IO ()
boot workState = do
undefined
writ <- undefined -- getWrit w
sendAtom w (work (eventId writ) (event writ))
playWorkerState :: Play -> WorkerState
playWorkerState = \case
PlayNone -> (1, Mug 0)
PlaySnap e m _ -> (e, m)
-- computeThread :: Worker -> IO ()
-- computeThread w = start
-- where
-- start = do
-- Just (Play p) <- recvPlea w
-- let (eventId, mug) = playWorkerState p
-- -- fuck it, we'll do it liv_o
-- boot :: WorkerState -> -> IO ()
-- boot w = do
-- writ <- atomically $ (getInput w)
-- sendAtom w (work (eventId writ) (event writ))
playWorkerState :: Play -> WorkerState
playWorkerState = \case
Nil -> (1, Mug 0)
NotNil (e, m, _) -> (e, m)
-- The flow here is that we start the worker and then we receive a play event
@ -257,7 +247,7 @@ recvLen = undefined
recvBytes :: Worker -> Word64 -> IO ByteString
recvBytes = undefined
recvAtom :: Worker -> IO (Atom)
recvAtom :: Worker -> IO Atom
recvAtom w = do
len <- recvLen w
bs <- recvBytes w len