Massive cleanup.

pkg/hs-urbit/lib/Atom.hs

@@ -1,191 +0,0 @@
-module Atom where
-
-import ClassyPrelude
-import Control.Lens
-import Data.Bits
-import Data.Flat
-import GHC.Int
-import GHC.Integer.GMP.Internals
-import GHC.Natural
-import GHC.Prim
-import GHC.Word
-import Test.QuickCheck.Arbitrary
-import Test.QuickCheck.Gen
-import Text.Printf
-
-import Data.Hashable (Hashable)
-
---------------------------------------------------------------------------------
-
-newtype Atom = MkAtom { unAtom :: Natural }
-  deriving newtype ( Eq, Ord, Num, Bits, Enum, Real, Integral, Flat, Hashable
-                   , NFData
-                   )
-
-instance Show Atom where
-  show (MkAtom a) = show a
-
-{-
-  An Atom with a bit-offset.
--}
-data Cursor = Cursor
-    { _cOffset :: {-# UNPACK #-} !Int
-    , _cBuffer :: !Atom
-    }
-  deriving (Eq, Ord, Show)
-
-data Slice = Slice
-    { _sOffset :: {-# UNPACK #-} !Int
-    , _sWidth  :: {-# UNPACK #-} !Int
-    , _sBuffer :: !Atom
-    }
-  deriving (Eq, Ord, Show)
-
-makeLenses ''Cursor
-makeLenses ''Slice
-
-
--- Instances -------------------------------------------------------------------
-
-instance Arbitrary Natural where
-  arbitrary = fromInteger . abs <$> arbitrary
-
-instance Arbitrary Atom where
-  arbitrary = do
-    arbitrary >>= \case
-      False -> MkAtom <$> arbitrary
-      True  -> arbitrary <&> ((`mod` 16) . MkAtom)
-
--- Conversion ------------------------------------------------------------------
-
-class IsAtom a where
-  toAtom   :: a -> Atom
-  fromAtom :: Atom -> a
-
-instance IsAtom Atom where
-  toAtom   = id
-  fromAtom = id
-
-instance IsAtom Natural where
-  toAtom              = MkAtom
-  fromAtom (MkAtom a) = a
-
-instance IsAtom Word8 where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Word16 where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Word32 where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Word64 where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Word where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Int where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-instance IsAtom Integer where
-  toAtom   = fromIntegral
-  fromAtom = fromIntegral
-
-
---------------------------------------------------------------------------------
-
-{-
-  TODO Support 32-bit archetectures.
--}
-
-wordBitWidth# :: Word# -> Word#
-wordBitWidth# w = minusWord# 64## (clz# w)
-
-wordBitWidth :: Word -> Word
-wordBitWidth (W# w) = W# (wordBitWidth# w)
-
-bigNatBitWidth# :: BigNat -> Word#
-bigNatBitWidth# nat =
-    lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##)
-  where
-    (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1#
-    lswBits          = wordBitWidth# (indexBigNat# nat lastIdx)
-
-atomBitWidth# :: Atom -> Word#
-atomBitWidth# (MkAtom (NatS# gl)) = wordBitWidth# gl
-atomBitWidth# (MkAtom (NatJ# bn)) = bigNatBitWidth# bn
-
-bitWidth :: Num a => Atom -> a
-bitWidth a = fromIntegral (W# (atomBitWidth# a))
-
---------------------------------------------------------------------------------
-
-cursor :: Atom -> Atom -> Cursor
-cursor offset buf = Cursor (fromIntegral offset) buf
-
-fromCursor :: Cursor -> Atom
-fromCursor (Cursor off buf) = shiftR buf off
-
-bumpCursor :: Word -> Cursor -> Cursor
-bumpCursor off = over cOffset (+ fromIntegral off)
-
-instance IsAtom Cursor where
-  toAtom (Cursor off bits) = shiftR bits off
-  fromAtom = Cursor 0
-
-
---------------------------------------------------------------------------------
-
-{-# INLINE slice #-}
-slice :: (Atom, Atom) -> Atom -> Atom
-slice (offset, size) buf =
-  fromSlice (Slice (fromAtom offset) (fromAtom size) buf)
-
-{-# INLINE fromSlice #-}
-fromSlice :: Slice -> Atom
-fromSlice (Slice off wid buf) = takeBits wid (shiftR buf off)
-
---------------------------------------------------------------------------------
-
-{-# INLINE takeBits #-}
-takeBits :: Int -> Atom -> Atom
-takeBits wid buf = buf .&. (shiftL (MkAtom 1) wid - 1)
-
-{-# INLINE takeBitsWord #-}
-takeBitsWord :: Int -> Word -> Word
-takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1)
-
-{-# INLINE bitIdx #-}
-bitIdx :: Int -> Atom -> Bool
-bitIdx idx buf = testBit buf idx
-
-{-# INLINE bitConcat #-}
-bitConcat :: Atom -> Atom -> Atom
-bitConcat x y = x .|. shiftL y (bitWidth x)
-
-
--- Bit Buffers -----------------------------------------------------------------
-
-data Buf = Buf !Int !Atom
-
-instance Show Buf where
-  show (Buf sz bits) = "0b"
-                    <> replicate (sz - bitWidth bits) '0'
-                    <> printf "%b (%d bits)" (toInteger bits) sz
-
-instance Semigroup Buf where
-  Buf xSz xBuf <> Buf ySz yBuf = Buf (xSz+ySz) (xBuf .|. shiftL yBuf xSz)
-
-instance Monoid Buf where
-  mempty = Buf 0 0
-
-instance IsAtom Buf where
-  toAtom (Buf _ bits) = bits
-  fromAtom bits = Buf (bitWidth bits) bits

pkg/hs-urbit/lib/Noun.hs

@@ -1,686 +1,29 @@
-{-# OPTIONS_GHC -funbox-strict-fields #-}
-
 module Noun
-  ( Noun, pattern Cell, pattern Atom, nounSize
+    ( module Noun.Core
-  , ToNoun(toNoun), FromNoun(parseNoun), fromNoun, fromNounErr
+    , module Noun.Convert
-  , Cord(..), Knot(..), Term(..), Tank(..), Plum(..)
+    , module Noun.Conversions
+    , module Noun.Atom
+    , module Noun.Jam
+    , module Noun.Cue
+    , module Noun.TH
+    , _Cue
     ) where
 
-import ClassyPrelude hiding (hash)
+import ClassyPrelude
-
 import Control.Lens
-import Control.Applicative
-import Control.Monad
-import Atom
-import Pill
-import Data.Void
-import Data.Word
-import GHC.Natural
-import GHC.Generics hiding (from)
-
-import Data.Bits                 (xor)
-import Data.Hashable             (hash)
-import Data.Typeable             (Typeable)
-import GHC.Integer.GMP.Internals (BigNat)
-import GHC.Natural               (Natural(NatS#, NatJ#))
-import GHC.Prim                  (reallyUnsafePtrEquality#)
-import GHC.Word                  (Word(W#))
-import Atom                      (Atom(MkAtom))
-import RIO                       (decodeUtf8Lenient)
-import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary))
-import Test.QuickCheck.Gen       (scale, resize, getSize)
-
-import qualified GHC.Generics as GHC
-import qualified Data.Char          as C
-import qualified Control.Monad.Fail as Fail
-
-
--- Types -----------------------------------------------------------------------
-
-data Noun
-    = NCell !Int !Word !Noun !Noun
-    | NAtom !Int !Atom
-
-pattern Cell x y <- NCell _ _ x y where
-  Cell = mkCell
-
-pattern Atom a <- NAtom _ a where
-  Atom = mkAtom
-
-data CellIdx = L | R
-  deriving (Eq, Ord, Show)
-
-type NounPath = [CellIdx]
 
+import Noun.Core
+import Noun.Convert
+import Noun.Conversions
+import Noun.Atom
+import Noun.Jam
+import Noun.Cue
+import Noun.TH
 
 --------------------------------------------------------------------------------
 
-instance Hashable Noun where
+_Cue :: Prism' ByteString Noun
-  hash = \case NCell h _ _ _ -> h
+_Cue = prism' jamBS (eitherToMaybe . cueBS)
-               NAtom h _     -> h
-  {-# INLINE hash #-}
-  hashWithSalt = defaultHashWithSalt
-  {-# INLINE hashWithSalt #-}
-
-instance Eq Noun where
-  (==) !x !y =
-    case reallyUnsafePtrEquality# x y of
-      1# -> True
-      _  -> case (x, y) of
-              (NAtom x1 a1, NAtom x2 a2) ->
-                  x1 == x2 && a1 == a2
-              (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) ->
-                  s1==s2 && x1==x2 && h1==h2 && t1==t2
-              _ ->
-                  False
-  {-# INLINE (==) #-}
-
-instance Ord Noun where
-  compare !x !y =
-    case reallyUnsafePtrEquality# x y of
-      1# -> EQ
-      _  -> case (x, y) of
-              (Atom _,     Cell _ _)   -> LT
-              (Cell _ _,   Atom _)     -> GT
-              (Atom a1,    Atom a2)    -> compare a1 a2
-              (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2
-  {-# INLINE compare #-}
-
-
-instance Show Noun where
-  show = \case Atom a   -> showAtom a
-               Cell x y -> fmtCell (show <$> (x : toTuple y))
   where
-      fmtCell :: [String] -> String
+    eitherToMaybe (Left _)  = Nothing
-      fmtCell xs = "[" <> intercalate " " xs <> "]"
+    eitherToMaybe (Right x) = Just x
-
-      toTuple :: Noun -> [Noun]
-      toTuple (Cell x xs) = x : toTuple xs
-      toTuple atom        = [atom]
-
-      showAtom :: Atom -> String
-      showAtom 0 = "0"
-      showAtom a =
-          let mTerm = do
-                t <- fromNoun (Atom a)
-                let ok = \x -> (x=='-' || C.isAlphaNum x)
-                guard (all ok (t :: Text))
-                pure ("%" <> unpack t)
-
-          in case mTerm of
-               Nothing -> show a
-               Just st -> st
-
-instance Arbitrary Noun where
-  arbitrary = resize 1000 go
-    where
-      dub x = Cell x x
-      go = do
-        sz  <- getSize
-        (bit, bat :: Bool) <- arbitrary
-        case (sz, bit, bat) of
-          ( 0, _,     _    ) -> Atom <$> arbitrary
-          ( _, False, _    ) -> Atom <$> arbitrary
-          ( _, True,  True ) -> dub <$> arbitrary
-          ( _, True,  _    ) -> scale (\x -> x-10) (Cell <$> go <*> go)
-
-
---------------------------------------------------------------------------------
-
-{-# INLINE nounSize #-}
-nounSize :: Noun -> Word
-nounSize = \case
-  NCell _ s _ _ -> s
-  NAtom _ _     -> 1
-
-{-# INLINE mkAtom #-}
-mkAtom :: Atom -> Noun
-mkAtom !a = NAtom (hash a) a
-
-{-# INLINE mkCell #-}
-mkCell :: Noun -> Noun -> Noun
-mkCell !h !t = NCell has siz h t
-  where
-    !siz = nounSize h + nounSize t
-    !has = hash h `combine` hash t
-
-
--- Stolen from Hashable Library ------------------------------------------------
-
-{-# INLINE combine #-}
-combine :: Int -> Int -> Int
-combine !h1 !h2 = (h1 * 16777619) `xor` h2
-
-{-# INLINE defaultHashWithSalt #-}
-defaultHashWithSalt :: Hashable a => Int -> a -> Int
-defaultHashWithSalt !salt !x = salt `combine` hash x
-
-
--- 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 Tour = Tour [Char]
-  deriving (Eq, Ord, Show)
-
-newtype Tape = Tape ByteString
-  deriving newtype (Eq, Ord, Show, IsString)
-
-newtype Cord = Cord { unCord :: ByteString }
-  deriving newtype (Eq, Ord, Show, IsString, NFData)
-
-
--- Chars -----------------------------------------------------------------------
-
-instance ToNoun Char where
-  toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord
-
-instance FromNoun Char where
-  parseNoun n = do
-    w :: Word32 <- parseNoun n
-    pure $ C.chr $ fromIntegral w
-
-
--- Pretty Printing -------------------------------------------------------------
-
-type Tang = [Tank]
-
-data Tank
-    = TLeaf Tape
-    | TPlum Plum
-    | TPalm (Tape, Tape, Tape, Tape) [Tank]
-    | TRose (Tape, Tape, Tape) [Tank]
-  deriving (Eq, Ord, Show)
-
-type Tile = Cord
-
-data WideFmt
-    = WideFmt { delimit :: Tile, enclose :: Maybe (Tile, Tile) }
-  deriving (Eq, Ord, Show)
-
-data TallFmt
-    = TallFmt { intro   :: Tile, indef   :: Maybe (Tile, Tile) }
-  deriving (Eq, Ord, Show)
-
-data PlumFmt
-    = PlumFmt (Maybe WideFmt) (Maybe TallFmt)
-  deriving (Eq, Ord, Show)
-
-data Plum
-    = PAtom Cord
-    | PPara Tile [Cord]
-    | PTree PlumFmt [Plum]
-    | PSbrk Plum
-  deriving (Eq, Ord, Show)
-
-
--- IResult ---------------------------------------------------------------------
-
-data IResult a = IError NounPath String | ISuccess a
-  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
-
-instance Applicative IResult where
-    pure  = ISuccess
-    (<*>) = ap
-
-instance Fail.MonadFail IResult where
-    fail err = traceM ("!" <> err <> "!") >> IError [] err
-
-instance Monad IResult where
-    return = pure
-    fail   = Fail.fail
-    ISuccess a      >>= k = k a
-    IError path err >>= _ = IError path err
-
-instance MonadPlus IResult where
-    mzero = fail "mzero"
-    mplus a@(ISuccess _) _ = a
-    mplus _ b              = b
-
-instance Alternative IResult where
-    empty = mzero
-    (<|>) = mplus
-
-instance Semigroup (IResult a) where
-    (<>) = mplus
-
-instance Monoid (IResult a) where
-    mempty  = fail "mempty"
-    mappend = (<>)
-
-
--- Result ----------------------------------------------------------------------
-
-data Result a = Error String | Success a
-  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
-
-instance Applicative Result where
-    pure  = Success
-    (<*>) = ap
-
-instance Fail.MonadFail Result where
-    fail err = Error err
-
-instance Monad Result where
-    return = pure
-    fail   = Fail.fail
-
-    Success a >>= k = k a
-    Error err >>= _ = Error err
-
-instance MonadPlus Result where
-    mzero = fail "mzero"
-    mplus a@(Success _) _ = a
-    mplus _ b             = b
-
-instance Alternative Result where
-    empty = mzero
-    (<|>) = mplus
-
-instance Semigroup (Result a) where
-    (<>) = mplus
-    {-# INLINE (<>) #-}
-
-instance Monoid (Result a) where
-    mempty  = fail "mempty"
-    mappend = (<>)
-
-
--- "Parser" --------------------------------------------------------------------
-
-type Failure f r   = NounPath -> String -> f r
-type Success a f r = a -> f r
-
-newtype Parser a = Parser {
-  runParser :: forall f r.  NounPath -> Failure f r -> Success a f r -> f r
-}
-
-instance Monad Parser where
-    m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks
-                                       in runParser m path kf ks'
-    return = pure
-    fail = Fail.fail
-
-instance Fail.MonadFail Parser where
-    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
-
-instance Functor Parser where
-    fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a)
-                                        in runParser m path kf ks'
-
-apP :: Parser (a -> b) -> Parser a -> Parser b
-apP d e = do
-  b <- d
-  b <$> e
-
-instance Applicative Parser where
-    pure a = Parser $ \_path _kf ks -> ks a
-    (<*>) = apP
-
-instance Alternative Parser where
-    empty = fail "empty"
-    (<|>) = mplus
-
-instance MonadPlus Parser where
-    mzero = fail "mzero"
-    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
-                                         in runParser a path kf' ks
-
-instance Semigroup (Parser a) where
-    (<>) = mplus
-
-instance Monoid (Parser a) where
-    mempty  = fail "mempty"
-    mappend = (<>)
-
-
--- Conversion ------------------------------------------------------------------
-
-class FromNoun a where
-  parseNoun :: Noun -> Parser a
-
-class ToNoun a where
-  toNoun :: a -> Noun
-
---------------------------------------------------------------------------------
-
-int2Word :: Int -> Word
-int2Word = fromIntegral
-
-word2Int :: Word -> Int
-word2Int = fromIntegral
-
-instance ToNoun ByteString where
-  toNoun bs = toNoun (int2Word (length bs), bs ^. from (pill . pillBS))
-
-instance ToNoun Text where -- XX TODO
-  toNoun t = toNoun (Cord (encodeUtf8 t))
-
-instance FromNoun Text where -- XX TODO
-  parseNoun n = do
-    Cord c <- parseNoun n
-    pure (decodeUtf8Lenient c)
-
-instance FromNoun ByteString where
-  parseNoun x = do
-    (word2Int -> len, atom) <- parseNoun x
-    let bs = atom ^. pill . pillBS
-    pure $ case compare (length bs) len of
-      EQ -> bs
-      LT -> bs <> replicate (len - length bs) 0
-      GT -> take len bs
-
---------------------------------------------------------------------------------
-
-newtype Term = MkTerm Text
-  deriving newtype (Eq, Ord, Show)
-
-instance ToNoun Term where -- XX TODO
-  toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t))
-
-instance FromNoun Term where -- XX TODO
-  parseNoun n = do
-    Cord c <- parseNoun n
-    pure (MkTerm (decodeUtf8Lenient c))
-
---------------------------------------------------------------------------------
-
-newtype Knot = MkKnot Text
-  deriving newtype (Eq, Ord, Show)
-
-instance ToNoun Knot where -- XX TODO
-  toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t))
-
-instance FromNoun Knot where -- XX TODO
-  parseNoun n = do
-    Cord c <- parseNoun n
-    pure (MkKnot (decodeUtf8Lenient c))
-
---------------------------------------------------------------------------------
-
---------------------------------------------------------------------------------
-
-fromNoun :: FromNoun a => Noun -> Maybe a
-fromNoun n = runParser (parseNoun n) [] onFail onSuccess
-  where
-    onFail p m  = Nothing
-    onSuccess x = Just x
-
-fromNounErr :: FromNoun a => Noun -> Either Text a
-fromNounErr n = runParser (parseNoun n) [] onFail onSuccess
-  where
-    onFail p m  = Left (pack m)
-    onSuccess x = Right x
-
-_Poet :: (ToNoun a, FromNoun a) => Prism' Noun a
-_Poet = prism' toNoun fromNoun
-
-
--- Trivial Conversion ----------------------------------------------------------
-
-instance ToNoun Void where
-  toNoun = absurd
-
-instance FromNoun Void where
-  parseNoun = fail "Can't produce void"
-
-instance ToNoun Noun where
-  toNoun = id
-
-instance FromNoun Noun where
-  parseNoun = pure
-
-
--- Loobean Conversion ----------------------------------------------------------
-
-instance ToNoun Bool where
-  toNoun True  = Atom 0
-  toNoun False = Atom 1
-
-instance FromNoun Bool where
-  parseNoun (Atom 0)   = pure True
-  parseNoun (Atom 1)   = pure False
-  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
-  toNoun = Atom
-
-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
-
-instance ToNoun Integer   where
-    toNoun = toNoun . (fromIntegral :: Integer -> Natural)
-
-instance FromNoun Integer where
-    parseNoun = fmap ((fromIntegral :: Natural -> Integer) . unAtom) . parseNoun
-
-
--- Word Conversion -------------------------------------------------------------
-
-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)
-
-wordToNoun :: Integral a => a -> Noun
-wordToNoun = Atom . fromIntegral
-
-nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
-nounToWord = parseNoun >=> atomToWord
-
-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 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
-
-
--- 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 ("Nullable: 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 = nounFromList (toNoun <$> xs)
-    where
-      nounFromList :: [Noun] -> Noun
-      nounFromList []     = Atom 0
-      nounFromList (x:xs) = Cell x (nounFromList 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)
-
-
--- Tank and Plum Conversion ----------------------------------------------------
-
-instance ToNoun WideFmt where toNoun (WideFmt x xs)      = toNoun (x, xs)
-instance ToNoun TallFmt where toNoun (TallFmt x xs)      = toNoun (x, xs)
-instance ToNoun PlumFmt where toNoun (PlumFmt wide tall) = toNoun (wide, tall)
-
-instance FromNoun WideFmt where parseNoun = fmap (uncurry WideFmt) . parseNoun
-instance FromNoun TallFmt where parseNoun = fmap (uncurry TallFmt) . parseNoun
-instance FromNoun PlumFmt where parseNoun = fmap (uncurry PlumFmt) . parseNoun
-
-instance ToNoun Plum where
-  toNoun = \case
-    PAtom cord -> toNoun cord
-    PPara t cs -> toNoun (Cord "para", t, cs)
-    PTree f ps -> toNoun (Cord "tree", f, ps)
-    PSbrk p    -> toNoun (Cord "sbrk", p)
-
-instance FromNoun Plum where
-  parseNoun = undefined
-
-instance ToNoun Tank where
-  toNoun = pure (Atom 0)
-
-instance FromNoun Tank where
-  parseNoun _ = pure (TLeaf (Tape "TODO: Tank Parsing"))
-
-
--- Tuple Conversions -----------------------------------------------------------
-
-instance ToNoun () where
-  toNoun () = Atom 0
-
-instance FromNoun () where
-  parseNoun (Atom 0) = pure ()
-  parseNoun x        = fail ("expecting `~`, but got " <> show x)
-
-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
-
-instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where
-  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)
-
-instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where
-  toNoun (p, q, r, s) = toNoun (p, (q, r, s))
-
-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)
-
-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)
-
-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)
-
-instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
-         , FromNoun f, FromNoun g
-         )
-      => FromNoun (a, b, c, d, e, f, g)
-      where
-  parseNoun n = do
-    (p, tail)          <- parseNoun n
-    (q, r, s, t, u, v) <- parseNoun tail
-    pure (p, q, r, s, t, u, v)
-
-instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
-         , FromNoun f, FromNoun g, FromNoun h
-         )
-      => FromNoun (a, b, c, d, e, f, g, h)
-      where
-  parseNoun n = do
-    (p, tail)             <- parseNoun n
-    (q, r, s, t, u, v, w) <- parseNoun tail
-    pure (p, q, r, s, t, u, v, w)
-
-instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
-         , FromNoun f, FromNoun g, FromNoun h, FromNoun i
-         )
-      => FromNoun (a, b, c, d, e, f, g, h, i)
-      where
-  parseNoun n = do
-    (p, tail)                <- parseNoun n
-    (q, r, s, t, u, v, w, x) <- parseNoun tail
-    pure (p, q, r, s, t, u, v, w, x)
-
-instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
-         , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j
-         )
-      => FromNoun (a, b, c, d, e, f, g, h, i, j)
-      where
-  parseNoun n = do
-    (p, tail)                   <- parseNoun n
-    (q, r, s, t, u, v, w, x, y) <- parseNoun tail
-    pure (p, q, r, s, t, u, v, w, x, y)

pkg/hs-urbit/lib/Noun/Atom.hs

@@ -0,0 +1,202 @@
+{-
+  TODO Support 32-bit archetectures.
+  TODO Support Big Endian.
+-}
+
+{-# OPTIONS_GHC -Werror #-}
+
+module Noun.Atom
+    ( Atom(..)
+    , atomBitWidth#, wordBitWidth#, wordBitWidth
+    , takeBitsWord, bitWidth
+    , atomBytes, bigNatWords, atomWords
+    ) where
+
+import ClassyPrelude
+import Control.Lens hiding (Index)
+
+import Data.Bits                 (shiftL, shiftR, (.&.), (.|.))
+import GHC.Exts                  (sizeofByteArray#)
+import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
+import GHC.Integer.GMP.Internals (indexBigNat#)
+import GHC.Integer.GMP.Internals (wordToBigNat, byteArrayToBigNat#, zeroBigNat)
+import GHC.Int                   (Int(..))
+import GHC.Natural               (Natural(..))
+import GHC.Prim                  (plusWord#, clz#, minusWord#)
+import GHC.Prim                  (Word#, subIntC#, timesWord#, int2Word#)
+import GHC.Word                  (Word(..))
+import System.IO.Unsafe          (unsafePerformIO)
+
+import qualified Data.Primitive.Types     as Prim
+import qualified Data.Primitive.ByteArray as Prim
+import qualified Data.Vector.Primitive    as VP
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.Unsafe   as BU
+
+
+-- Types -----------------------------------------------------------------------
+
+type Atom = Natural
+
+
+--------------------------------------------------------------------------------
+
+wordBitWidth# :: Word# -> Word#
+wordBitWidth# w = minusWord# 64## (clz# w)
+
+wordBitWidth :: Word -> Word
+wordBitWidth (W# w) = W# (wordBitWidth# w)
+
+bigNatBitWidth# :: BigNat -> Word#
+bigNatBitWidth# nat =
+    lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##)
+  where
+    (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1#
+    lswBits          = wordBitWidth# (indexBigNat# nat lastIdx)
+
+atomBitWidth# :: Atom -> Word#
+atomBitWidth# (NatS# gl) = wordBitWidth# gl
+atomBitWidth# (NatJ# bn) = bigNatBitWidth# bn
+
+bitWidth :: Num a => Atom -> a
+bitWidth a = fromIntegral (W# (atomBitWidth# a))
+
+--------------------------------------------------------------------------------
+
+{-# INLINE takeBitsWord #-}
+takeBitsWord :: Int -> Word -> Word
+takeBitsWord wid wor = wor .&. (shiftL 1 wid - 1)
+
+
+--------------------------------------------------------------------------------
+
+{-
+    A `Pill` is a bytestring without trailing zeros.
+-}
+newtype Pill = Pill { unPill :: ByteString }
+
+instance Eq Pill where
+  (==) x y = (x ^. pillBS) == (y ^. pillBS)
+
+instance Show Pill where
+  show = show . view pillBS
+
+--------------------------------------------------------------------------------
+
+strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq))
+      => seq -> seq
+strip buf = take (len - go 0 (len - 1)) buf
+  where
+    len = length buf
+    go n i | i < 0                  = n
+           | 0 == unsafeIndex buf i = go (n+1) (i-1)
+           | otherwise              = n
+
+pillBS :: Iso' Pill ByteString
+pillBS = iso to from
+  where
+    to :: Pill -> ByteString
+    to = strip . unPill
+
+    from :: ByteString -> Pill
+    from = Pill . strip
+
+
+--------------------------------------------------------------------------------
+
+bigNatWords :: Iso' BigNat (VP.Vector Word)
+bigNatWords = iso to from
+  where
+    to (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
+                                (Prim.ByteArray bArr)
+
+    from v@(VP.Vector off (I# len) (Prim.ByteArray buf)) =
+      case VP.length v of
+        0 -> zeroBigNat
+        1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w)
+        n -> if off /= 0 then error "words2Nat: bad-vec" else
+             byteArrayToBigNat# buf len
+
+--------------------------------------------------------------------------------
+
+natWords :: Iso' Natural (VP.Vector Word)
+natWords = naturalBigNat . bigNatWords
+
+naturalBigNat :: Iso' Natural BigNat
+naturalBigNat = iso to from
+  where
+    to = \case NatS# w  -> wordToBigNat w
+               NatJ# bn -> bn
+
+    from bn = case sizeofBigNat# bn of 0# -> 0
+                                       1# -> NatS# (bigNatToWord bn)
+                                       _  -> NatJ# bn
+
+--------------------------------------------------------------------------------
+
+-- TODO This assumes 64-bit words
+packedWord :: Iso' ByteString Word
+packedWord = iso to from
+ where
+    from wor = reverse $ fromList $ go 0 []
+      where
+        go i acc | i >= 8    = acc
+        go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc)
+
+    to buf = go 0 0
+      where
+        top        = min 8 (length buf)
+        i idx off  = shiftL (fromIntegral $ BS.index buf idx) off
+        go acc idx = if idx >= top then acc else
+                     go (acc .|. i idx (8*idx)) (idx+1)
+
+--------------------------------------------------------------------------------
+
+wordsToBytes :: VP.Vector Word -> VP.Vector Word8
+wordsToBytes (VP.Vector off sz buf) =
+  VP.Vector (off*8) (sz*8) buf
+
+bsToWords :: ByteString -> VP.Vector Word
+bsToWords bs =
+  VP.generate (1 + length bs `div` 8) $ \i ->
+    view packedWord (BS.drop (i*8) bs)
+
+{-
+    TODO Support Big-Endian
+    TODO This still has a (small) risk of segfaulting. The right thing to
+         do is to manually copy the data to the C heap, setup the
+         finalizers, and then manually construct a bytestring from
+         that pointer.  -- finalizers, and make a bytestring from that.
+-}
+bytesBS :: Iso' (VP.Vector Word8) ByteString
+bytesBS = iso to from
+  where
+    to :: VP.Vector Word8 -> ByteString
+    to (VP.Vector off sz buf) =
+        unsafePerformIO $ do
+          Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf
+          bs <- BU.unsafePackAddressLen sz ptr
+          evaluate $ force $ BS.copy $ BS.drop off bs
+
+    from :: ByteString -> VP.Vector Word8
+    from bs = VP.generate (length bs) (BS.index bs)
+
+pillWords :: Iso' Pill (VP.Vector Word)
+pillWords = iso toVec fromVec
+  where
+    toVec   = view (pillBS . to bsToWords)
+    fromVec = view (to wordsToBytes . bytesBS . from pillBS)
+
+--------------------------------------------------------------------------------
+
+atomWords :: Iso' Atom (VP.Vector Word)
+atomWords = natWords
+
+pill :: Iso' Atom Pill
+pill = iso toAtom fromPill
+  where
+    toAtom   = view (natWords . from pillWords)
+    fromPill = view (pillBS . to bsToWords . from natWords)
+
+atomBytes :: Iso' Atom ByteString
+atomBytes = pill . pillBS

pkg/hs-urbit/lib/Noun/Conversions.hs

@@ -0,0 +1,401 @@
+module Noun.Conversions
+  ( Cord(..), Knot(..), Term(..), Tank(..), Tang, Plum(..)
+  ) where
+
+import ClassyPrelude hiding (hash)
+
+import Control.Lens
+import Data.Void
+import Data.Word
+import Noun.Atom
+import Noun.Convert
+import Noun.Core
+import Noun.TH
+
+import GHC.Natural (Natural)
+import RIO         (decodeUtf8Lenient)
+
+import qualified Data.Char as C
+
+
+-- TODO XX Hack! ---------------------------------------------------------------
+
+instance Show Noun where
+  show = \case Atom a   -> showAtom a
+               Cell x y -> fmtCell (show <$> (x : toTuple y))
+    where
+      fmtCell :: [String] -> String
+      fmtCell xs = "[" <> intercalate " " xs <> "]"
+
+      toTuple :: Noun -> [Noun]
+      toTuple (Cell x xs) = x : toTuple xs
+      toTuple atom        = [atom]
+
+      showAtom :: Atom -> String
+      showAtom 0 = "0"
+      showAtom a =
+          let mTerm = do
+                t <- fromNoun (Atom a)
+                let ok = \x -> (x=='-' || C.isAlphaNum x)
+                guard (all ok (t :: Text))
+                pure ("%" <> unpack t)
+
+          in case mTerm of
+               Nothing -> show a
+               Just st -> st
+
+
+-- Noun ------------------------------------------------------------------------
+
+instance ToNoun Noun where
+  toNoun = id
+
+instance FromNoun Noun where
+  parseNoun = pure
+
+
+-- Void ------------------------------------------------------------------------
+
+instance ToNoun Void where
+  toNoun = absurd
+
+instance FromNoun Void where
+  parseNoun = fail "Can't produce void"
+
+
+-- Tour ------------------------------------------------------------------------
+
+newtype Tour = Tour [Char]
+  deriving (Eq, Ord, Show)
+
+
+-- Atom or Cell ----------------------------------------------------------------
+
+data AtomCell a c
+    = ACAtom a
+    | ACCell c
+  deriving (Eq, Ord, Show)
+
+instance (ToNoun a, ToNoun c) => ToNoun (AtomCell a c) where
+  toNoun (ACAtom a) = toNoun a
+  toNoun (ACCell c) = toNoun c
+
+instance (FromNoun a, FromNoun c) => FromNoun (AtomCell a c) where
+  parseNoun n = case n of
+    Atom _   -> ACAtom <$> parseNoun n
+    Cell _ _ -> ACCell <$> parseNoun n
+
+
+-- Nullable --------------------------------------------------------------------
+
+{-|
+    `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.
+-}
+type Nullable a = AtomCell () a
+
+
+-- Char ------------------------------------------------------------------------
+
+instance ToNoun Char where
+  toNoun = toNoun . (fromIntegral :: Int -> Word32) . C.ord
+
+instance FromNoun Char where
+  parseNoun n = do
+    w :: Word32 <- parseNoun n
+    pure $ C.chr $ fromIntegral w
+
+
+-- List ------------------------------------------------------------------------
+
+instance ToNoun a => ToNoun [a] where
+  toNoun xs = nounFromList (toNoun <$> xs)
+    where
+      nounFromList :: [Noun] -> Noun
+      nounFromList []     = Atom 0
+      nounFromList (x:xs) = Cell x (nounFromList 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
+
+
+-- Tape ------------------------------------------------------------------------
+
+newtype Tape = Tape [Char]
+  deriving newtype (Eq, Ord, Show)
+
+instance FromNoun Tape where
+  parseNoun = undefined
+
+instance ToNoun Tape where
+  toNoun = undefined
+
+
+-- Pretty Printing -------------------------------------------------------------
+
+type Tang = [Tank]
+
+type Tank = AtomCell Tape TankTree
+
+data TankTree
+    = Plum Plum
+    | Palm (Tape, Tape, Tape, Tape) [Tank]
+    | Rose (Tape, Tape, Tape) [Tank]
+  deriving (Eq, Ord, Show)
+
+data WideFmt = WideFmt { delimit :: Cord, enclose :: Maybe (Cord, Cord) }
+  deriving (Eq, Ord, Show)
+
+data TallFmt = TallFmt { intro :: Cord, indef :: Maybe (Cord, Cord) }
+  deriving (Eq, Ord, Show)
+
+data PlumFmt = PlumFmt (Maybe WideFmt) (Maybe TallFmt)
+  deriving (Eq, Ord, Show)
+
+type Plum = AtomCell Cord PlumTree
+
+data PlumTree
+    = Para Cord [Cord]
+    | Tree PlumFmt [Plum]
+    | Sbrk Plum
+  deriving (Eq, Ord, Show)
+
+deriveNoun ''WideFmt
+deriveNoun ''TallFmt
+deriveNoun ''PlumFmt
+deriveNoun ''TankTree
+deriveNoun ''PlumTree
+
+
+-- ByteString ------------------------------------------------------------------
+
+instance ToNoun ByteString where
+  toNoun bs = toNoun (int2Word (length bs), bs ^. from atomBytes)
+    where
+      int2Word :: Int -> Word
+      int2Word = fromIntegral
+
+instance FromNoun ByteString where
+    parseNoun x = do
+        (word2Int -> len, atom) <- parseNoun x
+        let bs = atom ^. atomBytes
+        pure $ case compare (length bs) len of
+          EQ -> bs
+          LT -> bs <> replicate (len - length bs) 0
+          GT -> take len bs
+      where
+        word2Int :: Word -> Int
+        word2Int = fromIntegral
+
+
+-- Text ------------------------------------------------------------------------
+
+instance ToNoun Text where -- XX TODO
+  toNoun t = toNoun (Cord (encodeUtf8 t))
+
+instance FromNoun Text where -- XX TODO
+  parseNoun n = do
+    Cord c <- parseNoun n
+    pure (decodeUtf8Lenient c)
+
+
+-- Term ------------------------------------------------------------------------
+
+newtype Term = MkTerm Text
+  deriving newtype (Eq, Ord, Show)
+
+instance ToNoun Term where -- XX TODO
+  toNoun (MkTerm t) = toNoun (Cord (encodeUtf8 t))
+
+instance FromNoun Term where -- XX TODO
+  parseNoun n = do
+    Cord c <- parseNoun n
+    pure (MkTerm (decodeUtf8Lenient c))
+
+
+-- Knot ------------------------------------------------------------------------
+
+newtype Knot = MkKnot Text
+  deriving newtype (Eq, Ord, Show)
+
+instance ToNoun Knot where -- XX TODO
+  toNoun (MkKnot t) = toNoun (Cord (encodeUtf8 t))
+
+instance FromNoun Knot where -- XX TODO
+  parseNoun n = do
+    Cord c <- parseNoun n
+    pure (MkKnot (decodeUtf8Lenient c))
+
+
+-- Bool ------------------------------------------------------------------------
+
+instance ToNoun Bool where
+  toNoun True  = Atom 0
+  toNoun False = Atom 1
+
+instance FromNoun Bool where
+  parseNoun (Atom 0)   = pure True
+  parseNoun (Atom 1)   = pure False
+  parseNoun (Cell _ _) = fail "expecting a bool, but got a cell"
+  parseNoun (Atom a)   = fail ("expecting a bool, but got " <> show a)
+
+
+-- Integer ---------------------------------------------------------------------
+
+instance ToNoun Integer where
+    toNoun = toNoun . (fromIntegral :: Integer -> Natural)
+
+instance FromNoun Integer where
+    parseNoun = fmap (fromIntegral :: Natural -> Integer) . parseNoun
+
+
+-- Words -----------------------------------------------------------------------
+
+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)
+
+wordToNoun :: Integral a => a -> Noun
+wordToNoun = Atom . fromIntegral
+
+nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
+nounToWord = parseNoun >=> atomToWord
+
+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 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
+
+
+-- 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)
+
+
+-- Tuple Conversions -----------------------------------------------------------
+
+instance ToNoun () where
+  toNoun () = Atom 0
+
+instance FromNoun () where
+  parseNoun (Atom 0) = pure ()
+  parseNoun x        = fail ("expecting `~`, but got " <> show x)
+
+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
+
+
+instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where
+  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)
+
+instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where
+  toNoun (p, q, r, s) = toNoun (p, (q, r, s))
+
+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)
+
+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)
+
+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)
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g
+         )
+      => FromNoun (a, b, c, d, e, f, g)
+      where
+  parseNoun n = do
+    (p, tail)          <- parseNoun n
+    (q, r, s, t, u, v) <- parseNoun tail
+    pure (p, q, r, s, t, u, v)
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h
+         )
+      => FromNoun (a, b, c, d, e, f, g, h)
+      where
+  parseNoun n = do
+    (p, tail)             <- parseNoun n
+    (q, r, s, t, u, v, w) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w)
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h, FromNoun i
+         )
+      => FromNoun (a, b, c, d, e, f, g, h, i)
+      where
+  parseNoun n = do
+    (p, tail)                <- parseNoun n
+    (q, r, s, t, u, v, w, x) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w, x)
+
+instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
+         , FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j
+         )
+      => FromNoun (a, b, c, d, e, f, g, h, i, j)
+      where
+  parseNoun n = do
+    (p, tail)                   <- parseNoun n
+    (q, r, s, t, u, v, w, x, y) <- parseNoun tail
+    pure (p, q, r, s, t, u, v, w, x, y)

pkg/hs-urbit/lib/Noun/Convert.hs

@@ -0,0 +1,189 @@
+module Noun.Convert
+  ( ToNoun(toNoun)
+  , FromNoun(parseNoun), fromNoun, fromNounErr
+  , Parser(..)
+  , CellIdx, NounPath
+  , Cord(..)
+  ) where
+
+import ClassyPrelude hiding (hash)
+import Noun.Core
+import Noun.Atom
+import Control.Lens
+
+import qualified Control.Monad.Fail as Fail
+
+
+-- Types -----------------------------------------------------------------------
+
+data CellIdx = L | R
+  deriving (Eq, Ord, Show)
+
+type NounPath = [CellIdx]
+
+
+-- IResult ---------------------------------------------------------------------
+
+data IResult a = IError NounPath String | ISuccess a
+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
+
+instance Applicative IResult where
+    pure  = ISuccess
+    (<*>) = ap
+
+instance Fail.MonadFail IResult where
+    fail err = IError [] err
+
+instance Monad IResult where
+    return = pure
+    fail   = Fail.fail
+    ISuccess a      >>= k = k a
+    IError path err >>= _ = IError path err
+
+instance MonadPlus IResult where
+    mzero = fail "mzero"
+    mplus a@(ISuccess _) _ = a
+    mplus _ b              = b
+
+instance Alternative IResult where
+    empty = mzero
+    (<|>) = mplus
+
+instance Semigroup (IResult a) where
+    (<>) = mplus
+
+instance Monoid (IResult a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- Result ----------------------------------------------------------------------
+
+data Result a = Error String | Success a
+  deriving (Eq, Show, Typeable, Functor, Foldable, Traversable)
+
+instance Applicative Result where
+    pure  = Success
+    (<*>) = ap
+
+instance Fail.MonadFail Result where
+    fail err = Error err
+
+instance Monad Result where
+    return = pure
+    fail   = Fail.fail
+
+    Success a >>= k = k a
+    Error err >>= _ = Error err
+
+instance MonadPlus Result where
+    mzero = fail "mzero"
+    mplus a@(Success _) _ = a
+    mplus _ b             = b
+
+instance Alternative Result where
+    empty = mzero
+    (<|>) = mplus
+
+instance Semigroup (Result a) where
+    (<>) = mplus
+    {-# INLINE (<>) #-}
+
+instance Monoid (Result a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- "Parser" --------------------------------------------------------------------
+
+type Failure f r   = NounPath -> String -> f r
+type Success a f r = a -> f r
+
+newtype Parser a = Parser {
+  runParser :: forall f r.  NounPath -> Failure f r -> Success a f r -> f r
+}
+
+instance Monad Parser where
+    m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks
+                                       in runParser m path kf ks'
+    return = pure
+    fail = Fail.fail
+
+instance Fail.MonadFail Parser where
+    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
+
+instance Functor Parser where
+    fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a)
+                                        in runParser m path kf ks'
+
+apP :: Parser (a -> b) -> Parser a -> Parser b
+apP d e = do
+  b <- d
+  b <$> e
+
+instance Applicative Parser where
+    pure a = Parser $ \_path _kf ks -> ks a
+    (<*>) = apP
+
+instance Alternative Parser where
+    empty = fail "empty"
+    (<|>) = mplus
+
+instance MonadPlus Parser where
+    mzero = fail "mzero"
+    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
+                                         in runParser a path kf' ks
+
+instance Semigroup (Parser a) where
+    (<>) = mplus
+
+instance Monoid (Parser a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+
+-- Conversion ------------------------------------------------------------------
+
+class FromNoun a where
+  parseNoun :: Noun -> Parser a
+
+class ToNoun a where
+  toNoun :: a -> Noun
+
+--------------------------------------------------------------------------------
+
+fromNoun :: FromNoun a => Noun -> Maybe a
+fromNoun n = runParser (parseNoun n) [] onFail onSuccess
+  where
+    onFail p m  = Nothing
+    onSuccess x = Just x
+
+fromNounErr :: FromNoun a => Noun -> Either Text a
+fromNounErr n = runParser (parseNoun n) [] onFail onSuccess
+  where
+    onFail p m  = Left (pack m)
+    onSuccess x = Right x
+
+
+-- Cord Conversions ------------------------------------------------------------
+
+newtype Cord = Cord { unCord :: ByteString }
+  deriving newtype (Eq, Ord, Show, IsString, NFData)
+
+instance ToNoun Cord where
+  toNoun (Cord bs) = Atom (bs ^. from atomBytes)
+
+instance FromNoun Cord where
+  parseNoun n = do
+    atom <- parseNoun n
+    pure $ Cord (atom ^. atomBytes)
+
+--- Atom Conversion ------------------------------------------------------------
+
+instance ToNoun Atom where
+  toNoun = Atom
+
+instance FromNoun Atom where
+  parseNoun = \case
+    Atom a   -> pure a
+    Cell _ _ -> fail "Expecting an atom, but got a cell"

pkg/hs-urbit/lib/Noun/Core.hs

@@ -0,0 +1,115 @@
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+{-# LANGUAGE Strict, StrictData #-}
+
+module Noun.Core
+  ( Noun, pattern Cell, pattern Atom, nounSize
+  ) where
+
+import ClassyPrelude hiding (hash)
+
+import Noun.Atom
+
+import Data.Bits                 (xor)
+import Data.Hashable             (hash)
+import GHC.Natural               (Natural)
+import GHC.Prim                  (reallyUnsafePtrEquality#)
+import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary))
+import Test.QuickCheck.Gen       (Gen, scale, resize, getSize)
+
+
+-- Types -----------------------------------------------------------------------
+
+data Noun
+    = NCell Int Word Noun Noun
+    | NAtom Int Atom
+
+{-# COMPLETE Cell, Atom #-}
+pattern Cell x y <- NCell _ _ x y where Cell = mkCell
+pattern Atom a   <- NAtom _ a     where Atom = mkAtom
+
+
+--------------------------------------------------------------------------------
+
+instance Hashable Noun where
+  hash = \case NCell h _ _ _ -> h
+               NAtom h _     -> h
+  {-# INLINE hash #-}
+  hashWithSalt = defaultHashWithSalt
+  {-# INLINE hashWithSalt #-}
+
+instance Eq Noun where
+  (==) x y =
+    case reallyUnsafePtrEquality# x y of
+      1# -> True
+      _  -> case (x, y) of
+              (NAtom x1 a1, NAtom x2 a2) ->
+                  x1 == x2 && a1 == a2
+              (NCell x1 s1 h1 t1, NCell x2 s2 h2 t2) ->
+                  s1==s2 && x1==x2 && h1==h2 && t1==t2
+              _ ->
+                  False
+  {-# INLINE (==) #-}
+
+instance Ord Noun where
+  compare x y =
+    case reallyUnsafePtrEquality# x y of
+      1# -> EQ
+      _  -> case (x, y) of
+              (Atom _,     Cell _ _)   -> LT
+              (Cell _ _,   Atom _)     -> GT
+              (Atom a1,    Atom a2)    -> compare a1 a2
+              (Cell h1 t1, Cell h2 t2) -> compare h1 h2 <> compare t1 t2
+  {-# INLINE compare #-}
+
+
+instance Arbitrary Noun where
+  arbitrary = resize 1000 go
+    where
+      dub x = Cell x x
+      go = do
+        sz  <- getSize
+        (bit, bat :: Bool) <- arbitrary
+        case (sz, bit, bat) of
+          ( 0, _,     _    ) -> Atom <$> genAtom
+          ( _, False, _    ) -> Atom <$> genAtom
+          ( _, True,  True ) -> dub <$> arbitrary
+          ( _, True,  _    ) -> scale (\x -> x-10) (Cell <$> go <*> go)
+
+genNatural :: Gen Natural
+genNatural = fromInteger . abs <$> arbitrary
+
+genAtom :: Gen Atom
+genAtom = do
+  arbitrary >>= \case
+    False -> genNatural
+    True  -> (`mod` 16) <$> genNatural
+
+--------------------------------------------------------------------------------
+
+{-# INLINE nounSize #-}
+nounSize :: Noun -> Word
+nounSize = \case
+  NCell _ s _ _ -> s
+  NAtom _ _     -> 1
+
+{-# INLINE mkAtom #-}
+mkAtom :: Atom -> Noun
+mkAtom a = NAtom (hash a) a
+
+{-# INLINE mkCell #-}
+mkCell :: Noun -> Noun -> Noun
+mkCell h t = NCell has siz h t
+  where
+    siz = nounSize h + nounSize t
+    has = hash h `combine` hash t
+
+
+-- Stolen from Hashable Library ------------------------------------------------
+
+{-# INLINE combine #-}
+combine :: Int -> Int -> Int
+combine h1 h2 = (h1 * 16777619) `xor` h2
+
+{-# INLINE defaultHashWithSalt #-}
+defaultHashWithSalt :: Hashable a => Int -> a -> Int
+defaultHashWithSalt salt x = salt `combine` hash x

pkg/hs-urbit/lib/Noun/Cue.hs

@@ -1,16 +1,16 @@
-module Cue (cue, cueBS) where
+module Noun.Cue (cue, cueBS) where
 
 import ClassyPrelude
-import Noun
 
-import Atom             (Atom(..))
+import Noun.Core
+import Noun.Atom
+
 import Control.Lens     (view, from)
 import Data.Bits        (shiftL, shiftR, (.|.), (.&.))
 import Foreign.Ptr      (Ptr, plusPtr, castPtr, ptrToWordPtr)
 import Foreign.Storable (peek)
 import GHC.Prim         (ctz#)
 import GHC.Word         (Word(..))
-import Pill             (atomBS, atomWords)
 import System.IO.Unsafe (unsafePerformIO)
 import Text.Printf      (printf)
 
@@ -25,7 +25,7 @@ cueBS :: ByteString -> Either DecodeExn Noun
 cueBS = doGet dNoun
 
 cue :: Atom -> Either DecodeExn Noun
-cue = cueBS . view atomBS
+cue = cueBS . view atomBytes
 
 
 -- Debugging -------------------------------------------------------------------
@@ -38,12 +38,6 @@ debugM _ = pure ()
 debugMId :: (Monad m, Show a) => String -> m a -> m a
 debugMId _ a = a
 
--- debugMId tag m = do
-  -- r <- m
-  -- debugM (tag <> ": " <> show r)
-  -- pure r
-
-
 
 -- Types -----------------------------------------------------------------------
 

pkg/hs-urbit/lib/Noun/Jam.hs

@@ -1,10 +1,10 @@
-module Jam (jam, jamBS) where
+module Noun.Jam (jam, jamBS) where
 
 import ClassyPrelude hiding (hash)
-import Noun
 
-import Atom                      (Atom(MkAtom), toAtom, bitWidth, takeBitsWord)
+import Noun.Core
-import Atom                      (wordBitWidth, wordBitWidth# , atomBitWidth#)
+import Noun.Atom
+
 import Control.Lens              (view, from)
 import Data.Bits                 (shiftL, shiftR, setBit, clearBit, (.|.))
 import Data.Vector.Primitive     ((!))
@@ -16,7 +16,6 @@ import GHC.Int                   (Int(I#))
 import GHC.Natural               (Natural(NatS#, NatJ#))
 import GHC.Prim                  (Word#, plusWord#, word2Int#)
 import GHC.Word                  (Word(W#))
-import Pill                      (bigNatWords, atomBS)
 import System.IO.Unsafe          (unsafePerformIO)
 
 import qualified Data.ByteString.Unsafe as BS
@@ -32,7 +31,7 @@ jamBS n = doPut bt sz (writeNoun n)
     (sz, bt) = unsafePerformIO (compress n)
 
 jam :: Noun -> Atom
-jam = view (from atomBS) . jamBS
+jam = view (from atomBytes) . jamBS
 
 
 -- Types -----------------------------------------------------------------------
@@ -189,8 +188,8 @@ writeAtomBigNat !(view bigNatWords -> words) = do
 
 {-# INLINE writeAtomBits #-}
 writeAtomBits :: Atom -> Put ()
-writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd
+writeAtomBits = \case NatS# wd -> writeAtomWord# wd
-                      MkAtom (NatJ# bn) -> writeAtomBigNat bn
+                      NatJ# bn -> writeAtomBigNat bn
 
 
 -- Put Instances ---------------------------------------------------------------
@@ -292,7 +291,7 @@ writeBackRef !a = do
     p <- pos <$> getS
     writeBit True
     writeBit True
-    writeMat (toAtom a)
+    writeMat (fromIntegral a)
 
 
 -- Calculate Jam Size and Backrefs ---------------------------------------------

pkg/hs-urbit/lib/Noun/Lens.hs

@@ -1,45 +1 @@
 module Noun.Lens where
-
-import ClassyPrelude
-import Pill
-import Noun
-import Atom
-import Control.Lens
-import Jam (jam, jamBS)
-import Cue (cue, cueBS)
-
---------------------------------------------------------------------------------
-
-eitherToMaybe (Left _)  = Nothing
-eitherToMaybe (Right x) = Just x
-
-_CueBytes :: Prism' ByteString Noun
-_CueBytes = prism' jamBS (eitherToMaybe . cueBS)
-
-_Cue :: Prism' Atom Noun
-_Cue = prism' jam (eitherToMaybe . cue)
-
---------------------------------------------------------------------------------
-
-loadNoun :: FilePath -> IO (Maybe Noun)
-loadNoun = fmap (preview _CueBytes) . readFile
-
-dumpJam :: FilePath -> Noun -> IO ()
-dumpJam fp = writeFile fp . view (re _CueBytes)
-
-tryCuePill :: PillFile -> IO ()
-tryCuePill pill =
-    loadNoun (show pill) >>= \case Nothing         -> print "nil"
-                                   Just (Atom _)   -> print "atom"
-                                   Just (Cell _ _) -> print "cell"
-
-tryCueJamPill :: PillFile -> IO ()
-tryCueJamPill pill = do
-  n <- loadNoun (show pill) >>= \case
-         Nothing           -> print "failure" >> pure (Atom 0)
-         Just n@(Atom _)   -> print "atom"    >> pure n
-         Just n@(Cell _ _) -> print "cell"    >> pure n
-
-  bs <- evaluate (force (jamBS n))
-
-  print ("jam size: " <> show (length bs))

pkg/hs-urbit/lib/Noun/TH.hs

@@ -2,11 +2,10 @@
     Generate FromNoun and ToNoun instances.
 -}
 
-module Noun.TH where
+module Noun.TH (deriveNoun) where
 
 import ClassyPrelude hiding (fromList)
-import Noun
+import Noun.Convert
-import Control.Lens
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 

pkg/hs-urbit/lib/Pill.hs

@@ -1,316 +0,0 @@
-{-
-    TODO Handle 32-bit architectures
-    TODO Handle big-endian.
-    TODO A faster version of this is possible:
-
-      - Get the byte-length of a file.
-      - Round up to a multiple of 8 (or 4 if 32bit cpu)
-      - Allocate a mutable vector of Word8 with that size.
-      - Read the file into the array.
-      - Manually cast to an array of Word.
-      - On big endian, update each words with `System.Endian.fromLE64`.
-      - If there are trailing 0 words, adjust the vector size to delete them.
-      - unsafeFreeze the vector.
-      - Run `byteArrayToBigNat#` on the underlying byte array.
-      - Convert the BigNat to a Natural, to an Atom.
-      - The whole thing becomes zero-copy for little endian machines, with
-        one zero-copy transformation of the whole structure on big-endian
-        machines.
--}
-
-module Pill
-  ( pill, pillBS, atomBS, bigNatWords, atomWords, PillFile(..), Pill(..)
-  ) where
-
-import ClassyPrelude
-import Atom
-import Data.Flat hiding (from, to)
-import Control.Monad.Except
-import Control.Lens hiding (index, Index)
-import Data.Either.Extra (mapLeft)
-import GHC.Natural
-import Data.Bits
-import GHC.Integer.GMP.Internals
-import GHC.Int
-import GHC.Word
-import GHC.Exts (sizeofByteArray#)
-import System.IO.Unsafe (unsafePerformIO)
-
-import qualified Data.Vector              as V
-import qualified Data.Primitive.Types     as Prim
-import qualified Data.Primitive.ByteArray as Prim
-import qualified Data.Vector.Primitive    as VP
-import qualified Data.Vector.Unboxed      as VU
-import qualified Data.ByteString          as BS
-import qualified Data.ByteString.Unsafe   as BU
-
-import Test.Tasty
-import Test.Tasty.TH
-import Test.Tasty.QuickCheck as QC
-import Test.QuickCheck
-
---------------------------------------------------------------------------------
-
-{-
-    A `Pill` is a bytestring without trailing zeros.
--}
-newtype Pill = Pill { unPill :: ByteString }
-
-instance Eq Pill where
-  (==) x y = (x ^. pillBS) == (y ^. pillBS)
-
-instance Show Pill where
-  show = show . view pillBS
-
---------------------------------------------------------------------------------
-
-strip :: (IsSequence seq, Int ~ Index seq, Eq (Element seq), Num (Element seq))
-      => seq -> seq
-strip buf = take (len - go 0 (len - 1)) buf
-  where
-    len = length buf
-    go n i | i < 0                  = n
-           | 0 == unsafeIndex buf i = go (n+1) (i-1)
-           | otherwise              = n
-
-pillBS :: Iso' Pill ByteString
-pillBS = iso to from
-  where
-    to :: Pill -> ByteString
-    to = strip . unPill
-
-    from :: ByteString -> Pill
-    from = Pill . strip
-
---------------------------------------------------------------------------------
-
-bigNatWords :: Iso' BigNat (VP.Vector Word)
-bigNatWords = iso to from
-  where
-    to (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
-                                (Prim.ByteArray bArr)
-
-    from v@(VP.Vector off (I# len) (Prim.ByteArray buf)) =
-      case VP.length v of
-        0 -> zeroBigNat
-        1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w)
-        n -> if off /= 0 then error "words2Nat: bad-vec" else
-             byteArrayToBigNat# buf len
-
---------------------------------------------------------------------------------
-
-bigNatBits :: Iso' BigNat (VU.Vector Bool)
-bigNatBits = undefined
-
-natWords :: Iso' Natural (VP.Vector Word)
-natWords = naturalBigNat . bigNatWords
-
-naturalBigNat :: Iso' Natural BigNat
-naturalBigNat = iso to from
-  where
-    to = \case NatS# w  -> wordToBigNat w
-               NatJ# bn -> bn
-
-    from bn = case sizeofBigNat# bn of 0# -> 0
-                                       1# -> NatS# (bigNatToWord bn)
-                                       _  -> NatJ# bn
-
---------------------------------------------------------------------------------
-
-dumbPackWord :: ByteString -> Word
-dumbPackWord bs = go 0 0 (toList bs)
-  where
-    go acc i []     = acc
-    go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs
-
--- TODO This assumes 64-bit words
-packedWord :: Iso' ByteString Word
-packedWord = iso to from
- where
-    from wor = reverse $ fromList $ go 0 []
-      where
-        go i acc | i >= 8    = acc
-        go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc)
-
-    to buf = go 0 0
-      where
-        top        = min 8 (length buf)
-        i idx off  = shiftL (fromIntegral $ BS.index buf idx) off
-        go acc idx = if idx >= top then acc else
-                     go (acc .|. i idx (8*idx)) (idx+1)
-
---------------------------------------------------------------------------------
-
-wordsToBytes :: VP.Vector Word -> VP.Vector Word8
-wordsToBytes (VP.Vector off sz buf) =
-  VP.Vector (off*8) (sz*8) buf
-
-bsToWords :: ByteString -> VP.Vector Word
-bsToWords bs =
-  VP.generate (1 + length bs `div` 8) $ \i ->
-    view packedWord (BS.drop (i*8) bs)
-
-{-
-    TODO Support Big-Endian
-    TODO This still has a (small) risk of segfaulting. The right thing to
-         do is to manually copy the data to the C heap, setup the
-         finalizers, and then manually construct a bytestring from
-         that pointer.  -- finalizers, and make a bytestring from that.
--}
-bytesBS :: Iso' (VP.Vector Word8) ByteString
-bytesBS = iso to from
-  where
-    to :: VP.Vector Word8 -> ByteString
-    to (VP.Vector off sz buf) =
-        unsafePerformIO $ do
-          Prim.Addr ptr <- evaluate $ Prim.byteArrayContents buf
-          bs <- BU.unsafePackAddressLen sz ptr
-          evaluate $ force $ BS.copy $ BS.drop off bs
-
-    from :: ByteString -> VP.Vector Word8
-    from bs = VP.generate (length bs) (BS.index bs)
-
-pillWords :: Iso' Pill (VP.Vector Word)
-pillWords = iso toVec fromVec
-  where
-    toVec   = view (pillBS . to bsToWords)
-    fromVec = view (to wordsToBytes . bytesBS . from pillBS)
-
---------------------------------------------------------------------------------
-
-{-
-    This is a stupid, but obviously correct version of `view (from pill)`.
--}
-dumbPackAtom :: Pill -> Atom
-dumbPackAtom = go 0 0 . toList . view pillBS
-  where
-    go acc i []     = acc
-    go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs
-
-atomNat :: Iso' Atom Natural
-atomNat = iso unAtom MkAtom
-
-atomWords :: Iso' Atom (VP.Vector Word)
-atomWords = atomNat . natWords
-
-pill :: Iso' Atom Pill
-pill = iso toAtom fromPill
-  where
-    toAtom   = view (atomNat . natWords . from pillWords)
-    fromPill = view (pillBS . to bsToWords . from natWords . from atomNat)
-
-atomBS :: Iso' Atom ByteString
-atomBS = pill . pillBS
-
---------------------------------------------------------------------------------
-
-_Tall :: Flat a => Prism' ByteString a
-_Tall = prism' flat (eitherToMaybe . unflat)
-  where
-    eitherToMaybe :: Either a b -> Maybe b
-    eitherToMaybe (Left x)  = Nothing
-    eitherToMaybe (Right x) = Just x
-
---------------------------------------------------------------------------------
-
-loadPill :: FilePath -> IO Pill
-loadPill = fmap Pill . readFile
-
-loadAtom :: FilePath -> IO Atom
-loadAtom = fmap (view $ from pillBS . from pill) . readFile
-
-loadFlat :: Flat a => FilePath -> IO (Either Text a)
-loadFlat = fmap (mapLeft tshow . unflat) . readFile
-
---------------------------------------------------------------------------------
-
-dumpPill :: FilePath -> Pill -> IO ()
-dumpPill fp = writeFile fp . view pillBS
-
-dumpAtom :: FilePath -> Atom -> IO ()
-dumpAtom fp = writeFile fp . view (pill . pillBS)
-
-dumpFlat :: Flat a => FilePath -> a -> IO ()
-dumpFlat fp = writeFile fp . flat
-
---------------------------------------------------------------------------------
-
-data PillFile = Brass | Ivory | Solid
-
-instance Show PillFile where
-  show = \case
-    Brass -> "./bin/brass.pill"
-    Solid -> "./bin/solid.pill"
-    Ivory -> "./bin/ivory.pill"
-
-tryLoadPill :: PillFile -> IO Atom
-tryLoadPill pill = do
-    a@(MkAtom nat) <- loadAtom (show pill)
-    putStrLn "loaded"
-    print (a > 0)
-    putStrLn "evaled"
-    print (take 10 $ VP.toList $ nat ^. natWords)
-    pure a
-
-tryPackPill :: PillFile -> IO ()
-tryPackPill pf = do
-  atm <- tryLoadPill pf
-  print $ length (atm ^. pill . pillBS)
-
--- Tests -----------------------------------------------------------------------
-
-instance Arbitrary ByteString where
-  arbitrary = fromList <$> arbitrary
-
-instance Arbitrary Pill where
-  arbitrary = Pill <$> arbitrary
-
-instance Arbitrary BigNat where
-  arbitrary = view naturalBigNat <$> arbitrary
-
-instance Show BigNat where
-  show = show . NatJ#
-
---------------------------------------------------------------------------------
-
-testIso :: Eq a => Iso' a b -> a -> Bool
-testIso iso x = x == (x ^. iso . from iso)
-
-roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool)
-roundTrip dump load x = x == load (dump x)
-
-equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool)
-equiv f g x = f x == g x
-
-check :: Atom -> Atom
-check = toAtom . (id :: Integer -> Integer) . fromAtom
-
---------------------------------------------------------------------------------
-
-prop_packWordSane = equiv (view packedWord) dumbPackWord . fromList
-prop_packWord     = testIso (from packedWord)
-prop_unpackWord   = roundTrip (view packedWord)
-                              (strip . view (from packedWord))
-                  . strip
-                  . take 8
-
-prop_unpackBigNat = testIso bigNatWords
-
-prop_packBigNat   = roundTrip (view (from bigNatWords) . VP.fromList)
-                              (strip . VP.toList . view bigNatWords)
-                  . strip
-
-prop_implodeBytes = roundTrip (view pillWords) (view (from pillWords))
-
-prop_explodeBytes = roundTrip (view (from pillWords) . VP.fromList)
-                              (strip . VP.toList . view pillWords)
-                  . strip
-
-prop_packAtomSane = equiv (view (from pill)) dumbPackAtom . Pill . fromList
-prop_unpackAtom   = roundTrip (view pill) (view (from pill))
-prop_packAtom     = roundTrip (view (from pill)) (view pill) . Pill . strip
-
---------------------------------------------------------------------------------
-
-main :: IO ()
-main = $(defaultMainGenerator)

pkg/hs-urbit/lib/Urbit/Ames.hs

@@ -1,18 +1,17 @@
 module Urbit.Ames where
 
 import ClassyPrelude
+
 import Data.IP
-
 import Noun
-import Atom
-
 import Network.Socket
 
 import qualified Data.Vector as V
 import qualified Urbit.Time  as Time
-
 import qualified Vere.Ames   as VA
 
+--------------------------------------------------------------------------------
+
 data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix }
 
 data Ames = Ames

pkg/hs-urbit/lib/Vere/Ames.hs

@@ -4,7 +4,6 @@ import ClassyPrelude
 import Data.IP
 import Data.Void
 import Noun
-import Atom
 import Noun.TH
 import Control.Lens
 

pkg/hs-urbit/lib/Vere/Http.hs

@@ -4,7 +4,6 @@ module Vere.Http where
 
 import ClassyPrelude
 import Noun
-import Atom
 import Noun.TH
 
 import qualified Data.CaseInsensitive as CI

pkg/hs-urbit/lib/Vere/Http/Server.hs

@@ -4,13 +4,11 @@ module Vere.Http.Server where
 
 import ClassyPrelude
 import Vere.Http
-import Atom
 import Noun
 import Noun.TH
 import Control.Lens
 
 import Control.Concurrent (ThreadId, killThread, forkIO)
-import Pill               (pill, pillBS, Pill(..))
 
 import qualified Data.ByteString             as BS
 import qualified Network.HTTP.Types          as H
@@ -120,12 +118,12 @@ bsOcts = iso toOcts fromOcts
   where
     toOcts :: ByteString -> Octs
     toOcts bs =
-      Octs (fromIntegral (length bs)) (bs ^. from (pill . pillBS))
+      Octs (fromIntegral (length bs)) (bs ^. from atomBytes)
 
     fromOcts :: Octs -> ByteString
     fromOcts (Octs (fromIntegral -> len) atm) = bs <> pad
       where
-        bs  = atm ^. pill . pillBS
+        bs  = atm ^. atomBytes
         pad = BS.replicate (max 0 (len - length bs)) 0
 
 readEvents :: W.Request -> IO Request

pkg/hs-urbit/lib/Vere/Log.hs

@@ -17,10 +17,6 @@ import ClassyPrelude hiding (init)
 import Control.Lens  hiding ((<|))
 
 import Noun
-import Atom
-import Jam
-import Pill
-import Noun.Lens
 import Data.Void
 import Database.LMDB.Raw
 import Foreign.Ptr
@@ -176,12 +172,12 @@ get txn db key =
 mdbValToAtom :: MDB_val -> IO Atom
 mdbValToAtom (MDB_val sz ptr) = do
   bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
-  pure (bs ^. from (pill . pillBS))
+  pure (bs ^. from atomBytes)
 
 mdbValToNoun :: MDB_val -> IO Noun
 mdbValToNoun (MDB_val sz ptr) = do
   bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
-  let res = bs ^? from pillBS . from pill . _Cue
+  let res = bs ^? _Cue
   maybeErr res "mdb bad cue"
 
 putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO ()
@@ -193,13 +189,13 @@ putRaw flags txn db key val =
 putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO ()
 putNoun flags txn db key val =
   byteStringAsMdbVal key $ \mKey ->
-  byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal ->
+  byteStringAsMdbVal (val ^. re _Cue) $ \mVal ->
   putRaw flags txn db mKey mVal
 
 putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO ()
 putJam flags txn db id (Jam atom) = do
   withWord64AsMDBval id $ \idVal -> do
-    let !bs = atom ^. pill . pillBS
+    let !bs = atom ^. atomBytes
     byteStringAsMdbVal bs $ \mVal -> do
       putRaw flags txn db idVal mVal
 

pkg/hs-urbit/lib/Vere/Pier.hs

@@ -3,7 +3,6 @@ module Vere.Pier where
 import ClassyPrelude
 
 import Noun
-import Pill
 import Vere.Pier.Types
 
 import qualified Vere.Log     as Log
@@ -22,7 +21,8 @@ ioDrivers = [] :: [IODriver]
 
 -- This is called to make a freshly booted pier. It assigns an identity to an
 -- event log and takes a chill pill.
-boot :: Pill -> FilePath -> LogIdentity -> IO (Serf, EventLog, EventId, Mug)
+boot :: ByteString -> FilePath -> LogIdentity
+     -> IO (Serf, EventLog, EventId, Mug)
 boot pill top id = do
   let logPath = top <> "/log"
 

pkg/hs-urbit/lib/Vere/Pier/Types.hs

@@ -3,7 +3,6 @@ module Vere.Pier.Types where
 import ClassyPrelude
 import Data.Void
 import Noun
-import Atom
 import Noun.TH
 import Database.LMDB.Raw
 import Urbit.Time

pkg/hs-urbit/lib/Vere/Serf.hs

@@ -2,22 +2,18 @@ module Vere.Serf where
 
 import ClassyPrelude
 import Control.Lens
+
 import Data.Void
-
 import Noun
-import Atom
-import Jam (jam, jamBS)
-import Cue (cue, cueBS)
-import Pill
-import Vere.Pier.Types
 import System.Process
+import Vere.Pier.Types
 
-import Foreign.Marshal.Alloc (alloca)
-import System.Exit (ExitCode)
 import Data.ByteString        (hGet)
 import Data.ByteString.Unsafe (unsafeUseAsCString)
+import Foreign.Marshal.Alloc  (alloca)
 import Foreign.Ptr            (castPtr)
 import Foreign.Storable       (poke, peek)
+import System.Exit            (ExitCode)
 
 import qualified Data.ByteString.Unsafe as BS
 import qualified Urbit.Time             as Time
@@ -238,7 +234,7 @@ replayEvents w (wid, wmug) identity lastCommitedId getEvents = do
         loop vLast (curEvent + toRead)
 
 
-bootSerf :: Serf -> LogIdentity -> Pill -> IO (EventId, Mug)
+bootSerf :: Serf -> LogIdentity -> ByteString -> IO (EventId, Mug)
 bootSerf w ident pill =
   do
     recvPlea w >>= \case
@@ -332,9 +328,7 @@ sendAtom s a = do
   hFlush (sendHandle s)
   traceM "sendAtom.return ()"
 
-atomBytes :: Iso' Atom ByteString
+packAtom :: ByteString -> Atom
-atomBytes = pill . pillBS
-
 packAtom = view (from atomBytes)
 
 unpackAtom :: Atom -> ByteString

pkg/hs-urbit/package.yaml

@@ -8,6 +8,7 @@ library:
     - -fwarn-incomplete-patterns
     - -fwarn-unused-binds
     - -fwarn-unused-imports
+    # -Werror
     - -O2
 
 dependencies:

pkg/hs-vere/app/uterm/Main.hs

@@ -2,22 +2,12 @@ module Main where
 
 import ClassyPrelude
 import Control.Lens
-import Pill hiding (main)
+import Noun
-import Noun.Lens
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
 main = do
-  -- print "load brass" -- void getLine
-  -- tryLoadPill Brass
-
-  -- print "load ivory" -- void getLine
-  -- tryLoadPill Ivory
-
-  -- print "load solid" -- void getLine
-  -- tryLoadPill Solid
-
   print "cue brass" -- void getLine
   tryCueJamPill Brass
 
@@ -26,3 +16,34 @@ main = do
 
   print "cue solid" -- void getLine
   tryCueJamPill Solid
+
+loadNoun :: FilePath -> IO (Maybe Noun)
+loadNoun = fmap (preview _Cue) . readFile
+
+dumpJam :: FilePath -> Noun -> IO ()
+dumpJam fp = writeFile fp . view (re _Cue)
+
+tryCuePill :: PillFile -> IO ()
+tryCuePill pill =
+    loadNoun (show pill) >>= \case Nothing         -> print "nil"
+                                   Just (Atom _)   -> print "atom"
+                                   Just (Cell _ _) -> print "cell"
+
+tryCueJamPill :: PillFile -> IO ()
+tryCueJamPill pill = do
+  n <- loadNoun (show pill) >>= \case
+         Nothing           -> print "failure" >> pure (Atom 0)
+         Just n@(Atom _)   -> print "atom"    >> pure n
+         Just n@(Cell _ _) -> print "cell"    >> pure n
+
+  bs <- evaluate (force (jamBS n))
+
+  print ("jam size: " <> show (length bs))
+
+data PillFile = Brass | Ivory | Solid
+
+instance Show PillFile where
+  show = \case
+    Brass -> "./bin/brass.pill"
+    Solid -> "./bin/solid.pill"
+    Ivory -> "./bin/ivory.pill"