Massive cleanup.

This commit is contained in:
Benjamin Summers 2019-07-11 18:16:40 -07:00
parent d5244af9d1
commit 31d8e217c2
21 changed files with 997 additions and 1300 deletions

View File

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

View File

@ -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(..)
( 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 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
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))
_Cue :: Prism' ByteString Noun
_Cue = prism' jamBS (eitherToMaybe . cueBS)
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
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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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
atomBytes = pill . pillBS
packAtom :: ByteString -> Atom
packAtom = view (from atomBytes)
unpackAtom :: Atom -> ByteString

View File

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

View File

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