Lots of noun parsing/unparsing code.

pkg/hair/lib/Data/Noun/Jam.hs

@@ -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)

pkg/hair/lib/Data/Noun/Poet.hs

@@ -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
+atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a
-  toNoun = Atom . fromIntegral
+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
+wordToNoun :: Integral a => a -> Noun
-  toNoun = Atom . fromIntegral
+wordToNoun = Atom . fromIntegral
 
-instance FromNoun Word32 where
+nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
-  parseNoun (Cell _ _) = fail "cell is not an atom"
+nounToWord = parseNoun >=> atomToWord
-  parseNoun (Atom a)   = pure (fromIntegral a) -- TODO Overflow
 
-instance ToNoun Word64 where
+instance ToNoun Word    where toNoun = wordToNoun
-  toNoun = Atom . fromIntegral
+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
+instance FromNoun Word    where parseNoun = nounToWord
-  parseNoun (Cell _ _) = fail "cell is not an atom"
+instance FromNoun Word8   where parseNoun = nounToWord
-  parseNoun (Atom a)   = pure (fromIntegral a) -- TODO Overflow
+instance FromNoun Word16  where parseNoun = nounToWord
-
+instance FromNoun Word32  where parseNoun = nounToWord
-instance ToNoun Natural where
+instance FromNoun Word64  where parseNoun = nounToWord
-  toNoun = toNoun . toAtom
 
 
--- 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)
+  toNoun (x, y, z) = toNoun (x, (y, z))
-                   $ Cell (toNoun y) (toNoun 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)
+  toNoun (p, q, r, s) = toNoun (p, (q, r, s))
-                      $ Cell (toNoun y)
-                      $ Cell (toNoun z) (toNoun a)
 
-instance ToNoun a => ToNoun [a] where
+instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d)
-  toNoun xs = fromList (toNoun <$> xs)
+      => 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)

pkg/hair/lib/Vere/Isle.hs

@@ -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)

pkg/hair/lib/Vere/Worker.hs

@@ -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
+newtype Job = Job Void
-  deriving (Eq, Show)
+  deriving newtype (Eq, Show, ToNoun, FromNoun)
 
-data Tank = Tank Void
+newtype Tank = Tank Void
-  deriving (Eq, Show)
+  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 }
+newtype ShipId = ShipId (Ship, Bool)
-  deriving (Eq, Show)
+  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
 --------------------------------------------------------------------------------
 
-data Play
+type Play = Nullable (EventId, Mug, ShipId)
-    = 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
-
---------------------------------------------------------------------------------
 
 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)
+      Nil              -> (1, Mug 0)
-  PlaySnap e m _ -> (e, m)
+      NotNil (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))
 
 
 -- 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