diff --git a/pkg/hs-urbit/lib/Atom.hs b/pkg/hs-urbit/lib/Atom.hs deleted file mode 100644 index c0e8979cbb..0000000000 --- a/pkg/hs-urbit/lib/Atom.hs +++ /dev/null @@ -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 diff --git a/pkg/hs-urbit/lib/Noun.hs b/pkg/hs-urbit/lib/Noun.hs index c13f36dbf9..dda9aa5526 100644 --- a/pkg/hs-urbit/lib/Noun.hs +++ b/pkg/hs-urbit/lib/Noun.hs @@ -1,686 +1,29 @@ -{-# OPTIONS_GHC -funbox-strict-fields #-} - module Noun - ( Noun, pattern Cell, pattern Atom, nounSize - , ToNoun(toNoun), FromNoun(parseNoun), fromNoun, fromNounErr - , Cord(..), Knot(..), Term(..), Tank(..), Plum(..) - ) where - -import ClassyPrelude hiding (hash) + ( module Noun.Core + , module Noun.Convert + , module Noun.Conversions + , module Noun.Atom + , module Noun.Jam + , module Noun.Cue + , module Noun.TH + , _Cue + ) where +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 - 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 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 - -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 +_Cue :: Prism' ByteString Noun +_Cue = prism' jamBS (eitherToMaybe . cueBS) 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) + eitherToMaybe (Left _) = Nothing + eitherToMaybe (Right x) = Just x diff --git a/pkg/hs-urbit/lib/Noun/Atom.hs b/pkg/hs-urbit/lib/Noun/Atom.hs new file mode 100644 index 0000000000..88dd6807d6 --- /dev/null +++ b/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 diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs new file mode 100644 index 0000000000..06c8fb404a --- /dev/null +++ b/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) diff --git a/pkg/hs-urbit/lib/Noun/Convert.hs b/pkg/hs-urbit/lib/Noun/Convert.hs new file mode 100644 index 0000000000..961448e746 --- /dev/null +++ b/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" diff --git a/pkg/hs-urbit/lib/Noun/Core.hs b/pkg/hs-urbit/lib/Noun/Core.hs new file mode 100644 index 0000000000..00801a0d42 --- /dev/null +++ b/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 diff --git a/pkg/hs-urbit/lib/Cue.hs b/pkg/hs-urbit/lib/Noun/Cue.hs similarity index 97% rename from pkg/hs-urbit/lib/Cue.hs rename to pkg/hs-urbit/lib/Noun/Cue.hs index b076225d94..89fd2ac49c 100644 --- a/pkg/hs-urbit/lib/Cue.hs +++ b/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 ----------------------------------------------------------------------- diff --git a/pkg/hs-urbit/lib/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs similarity index 95% rename from pkg/hs-urbit/lib/Jam.hs rename to pkg/hs-urbit/lib/Noun/Jam.hs index 3f838c30c9..5b9c94d7ba 100644 --- a/pkg/hs-urbit/lib/Jam.hs +++ b/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 Atom (wordBitWidth, wordBitWidth# , atomBitWidth#) +import Noun.Core +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 - MkAtom (NatJ# bn) -> writeAtomBigNat bn +writeAtomBits = \case NatS# wd -> writeAtomWord# wd + 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 --------------------------------------------- diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 7bbc6ab348..e46024da30 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/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)) diff --git a/pkg/hs-urbit/lib/Noun/TH.hs b/pkg/hs-urbit/lib/Noun/TH.hs index b7155fa6a8..e09f62264f 100644 --- a/pkg/hs-urbit/lib/Noun/TH.hs +++ b/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 Control.Lens +import Noun.Convert import Language.Haskell.TH import Language.Haskell.TH.Syntax diff --git a/pkg/hs-urbit/lib/Pill.hs b/pkg/hs-urbit/lib/Pill.hs deleted file mode 100644 index fe546e3858..0000000000 --- a/pkg/hs-urbit/lib/Pill.hs +++ /dev/null @@ -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) diff --git a/pkg/hs-urbit/lib/Urbit/Ames.hs b/pkg/hs-urbit/lib/Urbit/Ames.hs index 3e9bc9219b..9bcf0991e8 100644 --- a/pkg/hs-urbit/lib/Urbit/Ames.hs +++ b/pkg/hs-urbit/lib/Urbit/Ames.hs @@ -1,17 +1,16 @@ 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 Urbit.Time as Time +import qualified Vere.Ames as VA -import qualified Vere.Ames as VA +-------------------------------------------------------------------------------- data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix } diff --git a/pkg/hs-urbit/lib/Vere/Ames.hs b/pkg/hs-urbit/lib/Vere/Ames.hs index 443a85cd72..f04f525f3f 100644 --- a/pkg/hs-urbit/lib/Vere/Ames.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Http.hs b/pkg/hs-urbit/lib/Vere/Http.hs index e003900f48..665b3cd7fc 100644 --- a/pkg/hs-urbit/lib/Vere/Http.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index d26e7b4e8d..de70a6889b 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Log.hs b/pkg/hs-urbit/lib/Vere/Log.hs index 78804aa658..c0ddea467b 100644 --- a/pkg/hs-urbit/lib/Vere/Log.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Pier.hs b/pkg/hs-urbit/lib/Vere/Pier.hs index a3e7505069..6f91e74847 100644 --- a/pkg/hs-urbit/lib/Vere/Pier.hs +++ b/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" diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs index 1c31d4a263..07f08d34c8 100644 --- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs +++ b/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 diff --git a/pkg/hs-urbit/lib/Vere/Serf.hs b/pkg/hs-urbit/lib/Vere/Serf.hs index 6b425d6e24..da426532ca 100644 --- a/pkg/hs-urbit/lib/Vere/Serf.hs +++ b/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 (hGet) import Data.ByteString.Unsafe (unsafeUseAsCString) -import Foreign.Ptr (castPtr) -import Foreign.Storable (poke, peek) +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 -atomBytes = pill . pillBS - +packAtom :: ByteString -> Atom packAtom = view (from atomBytes) unpackAtom :: Atom -> ByteString diff --git a/pkg/hs-urbit/package.yaml b/pkg/hs-urbit/package.yaml index 19b1b85a30..ca60ee373d 100644 --- a/pkg/hs-urbit/package.yaml +++ b/pkg/hs-urbit/package.yaml @@ -8,6 +8,7 @@ library: - -fwarn-incomplete-patterns - -fwarn-unused-binds - -fwarn-unused-imports + # -Werror - -O2 dependencies: diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 537f6e1056..ec12f6ed19 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/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.Lens +import Noun -------------------------------------------------------------------------------- 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"