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

Merge branch 'king-haskell' of github.com:urbit/urbit into king-auto-connect

Browse Source
This commit is contained in:
Benjamin Summers 2020-01-23 01:49:18 -08:00
commit c91e0a678f
27 changed files with 409 additions and 246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkg/hs/king/lib/Ur/Arvo/Event.hs
View File

@ -55,7 +55,7 @@ passToBS Pass{..} = C.singleton 'b' <>
(Ed.unPublicKey passCrypt)
instance ToNoun Pass where
toNoun p = Atom $ (passToBS p) ^. from atomBytes
toNoun = Atom . bytesAtom . passToBS
instance FromNoun Pass where
parseNoun n = named "Pass" $ do
@ -82,9 +82,7 @@ data Ring = Ring { ringSign :: BS.ByteString, ringCrypt :: BS.ByteString }
instance ToNoun Ring where
toNoun Ring{..} =
Atom $ bs ^. from atomBytes
where
bs = C.singleton 'B' <> ringSign <> ringCrypt
Atom $ bytesAtom (C.singleton 'B' <> ringSign <> ringCrypt)
instance FromNoun Ring where
parseNoun n = named "Ring" $ do

1
pkg/hs/king/lib/Ur/King/Main.hs
View File

@ -66,7 +66,6 @@ import RIO.Directory
import Ur.Arvo
import Ur.King.Config
import Ur.Noun hiding (Parser)
import Ur.Noun.Atom
import Ur.Noun.Conversions (cordToUW)
import Ur.Vere.Dawn
import Ur.Vere.Pier

4
pkg/hs/king/lib/Ur/Noun.hs
View File

@ -4,7 +4,7 @@
This module just re-exports things from submodules.
-}
module Ur.Noun
( module Ur.Noun.Atom
( module Urbit.Atom
, module Data.Word
, module Ur.Noun.Conversions
, module Ur.Noun.Convert
@ -23,7 +23,7 @@ import ClassyPrelude
import Control.Lens
import Data.Word
import Ur.Noun.Atom
import Urbit.Atom
import Ur.Noun.Conversions
import Ur.Noun.Convert
import Ur.Noun.Core

203
pkg/hs/king/lib/Ur/Noun/Atom.hs
View File

@ -1,203 +0,0 @@
{-# OPTIONS_GHC -Werror #-}
{-|
Atom implementation with fast conversions between bytestrings
and atoms.
TODO Support 32-bit archetectures.
TODO Support Big Endian.
-}
module Ur.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 (Ptr(Ptr), sizeofByteArray#)
import GHC.Int (Int(..))
import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
import GHC.Integer.GMP.Internals (indexBigNat#)
import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat)
import GHC.Natural (Natural(..))
import GHC.Prim (clz#, minusWord#, plusWord#)
import GHC.Prim (Word#, int2Word#, subIntC#, timesWord#)
import GHC.Word (Word(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.Primitive.ByteArray as Prim
import qualified Data.Primitive.Types as Prim
import qualified Data.Vector.Primitive as VP
import qualified Foreign.ForeignPtr.Unsafe as Ptr
-- 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
-}
bytesBS :: Iso' (VP.Vector Word8) ByteString
bytesBS = iso to from
where
to :: VP.Vector Word8 -> ByteString
to (VP.Vector off sz buf) =
unsafePerformIO $ do
fp <- BS.mallocByteString sz
let Ptr a = Ptr.unsafeForeignPtrToPtr fp -- Safe b/c returning fp
Prim.copyByteArrayToAddr (Prim.Addr a) buf 0 sz
pure (BS.PS fp off sz)
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

10
pkg/hs/king/lib/Ur/Noun/Conversions.hs
View File

@ -23,7 +23,7 @@ import Data.Void
import Data.Word
import Text.Regex.TDFA
import Text.Regex.TDFA.Text ()
import Ur.Noun.Atom
import Urbit.Atom
import Ur.Noun.Convert
import Ur.Noun.Core
import Ur.Noun.TH
@ -479,10 +479,10 @@ newtype Bytes = MkBytes { unBytes :: ByteString }
deriving newtype (Eq, Ord, Show)
instance ToNoun Bytes where
toNoun = Atom . view (from atomBytes) . unBytes
toNoun = Atom . bytesAtom . unBytes
instance FromNoun Bytes where
parseNoun = named "Bytes" . fmap (MkBytes . view atomBytes) . parseNoun
parseNoun = named "Bytes" . fmap (MkBytes . atomBytes) . parseNoun
-- Octs ------------------------------------------------------------------------
@ -492,7 +492,7 @@ newtype Octs = Octs { unOcts :: ByteString }
instance ToNoun Octs where
toNoun (Octs bs) =
toNoun (int2Word (length bs), bs ^. from atomBytes)
toNoun (int2Word (length bs), bytesAtom bs)
where
int2Word :: Int -> Word
int2Word = fromIntegral
@ -500,7 +500,7 @@ instance ToNoun Octs where
instance FromNoun Octs where
parseNoun x = named "Octs" $ do
(word2Int -> len, atom) <- parseNoun x
let bs = atom ^. atomBytes
let bs = atomBytes atom
pure $ Octs $ case compare (length bs) len of
EQ -> bs
LT -> bs <> replicate (len - length bs) 0

11
pkg/hs/king/lib/Ur/Noun/Core.hs
View File

@ -18,18 +18,17 @@ module Ur.Noun.Core
import ClassyPrelude hiding (hash)
import Ur.Noun.Atom
import Urbit.Atom
import Control.Lens (from, view, (&), (^.))
import Data.Bits (xor)
import Data.Function ((&))
import Data.Hashable (hash)
import GHC.Natural (Natural)
import GHC.Prim (reallyUnsafePtrEquality#)
import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary))
import Test.QuickCheck.Gen (Gen, getSize, resize, scale)
import qualified Data.Char as C
import qualified Data.Text.Encoding as T
import qualified Data.Char as C
-- Types -----------------------------------------------------------------------
@ -59,12 +58,12 @@ instance Hashable Noun where
{-# INLINE hashWithSalt #-}
textToUtf8Atom :: Text -> Noun
textToUtf8Atom = Atom . view (from atomBytes) . encodeUtf8
textToUtf8Atom = Atom . utf8Atom
utf8AtomToText :: Noun -> Either Text Text
utf8AtomToText = \case
Cell _ _ -> Left "Expected @t, but got ^"
Atom atm -> T.decodeUtf8' (atm ^. atomBytes) & \case
Atom atm -> atomUtf8 atm & \case
Left err -> Left (tshow err)
Right tx -> pure tx

10
pkg/hs/king/lib/Ur/Noun/Cue.hs
View File

@ -9,11 +9,11 @@ module Ur.Noun.Cue (cue, cueExn, cueBS, cueBSExn, DecodeErr) where
import ClassyPrelude
import Ur.Noun.Atom
import Urbit.Atom
import Ur.Noun.Core
import Control.Lens (from, view, (&), (^.))
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.Function ((&))
import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr)
import Foreign.Storable (peek)
import GHC.Prim (ctz#)
@ -38,10 +38,10 @@ cueBSExn bs =
Right x -> pure x
cue :: Atom -> Either DecodeErr Noun
cue = cueBS . view atomBytes
cue = cueBS . atomBytes
cueExn :: MonadIO m => Atom -> m Noun
cueExn atm = cueBSExn (atm ^. atomBytes)
cueExn = cueBSExn . atomBytes
-- Debugging -------------------------------------------------------------------
@ -256,7 +256,7 @@ dWord = do
dAtomBits :: Word -> Get Atom
dAtomBits !(fromIntegral -> bits) = do
debugMId ("dAtomBits(" <> show bits <> ")") $ do
fmap (view $ from atomWords) $
fmap wordsAtom $
VP.generateM bufSize $ \i -> do
debugM (show i)
if (i == lastIdx && numExtraBits /= 0)

8
pkg/hs/king/lib/Ur/Noun/Jam.hs
View File

@ -9,10 +9,10 @@ module Ur.Noun.Jam (jam, jamBS) where
import ClassyPrelude hiding (hash)
import Ur.Noun.Atom
import Urbit.Atom
import Urbit.Atom.Internal
import Ur.Noun.Core
import Control.Lens (from, view)
import Data.Bits (clearBit, setBit, shiftL, shiftR, (.|.))
import Data.Vector.Primitive ((!))
import Foreign.Marshal.Alloc (callocBytes, free)
@ -38,7 +38,7 @@ jamBS n = doPut bt sz (writeNoun n)
(sz, bt) = unsafePerformIO (compress n)
jam :: Noun -> Atom
jam = view (from atomBytes) . jamBS
jam = bytesAtom . jamBS
-- Types -----------------------------------------------------------------------
@ -188,7 +188,7 @@ writeAtomWord (W# w) = writeAtomWord# w
-}
{-# INLINE writeAtomBigNat #-}
writeAtomBigNat :: BigNat -> Put ()
writeAtomBigNat !(view bigNatWords -> words) = do
writeAtomBigNat !(bigNatWords -> words) = do
let lastIdx = VP.length words - 1
for_ [0..(lastIdx-1)] $ \i ->
writeWord (words ! i)

4
pkg/hs/king/lib/Ur/Noun/Tree.hs
View File

@ -13,7 +13,7 @@ module Ur.Noun.Tree
import ClassyPrelude
import Control.Lens hiding (non)
import Ur.Noun.Atom
import Urbit.Atom
import Ur.Noun.Conversions ()
import Ur.Noun.Convert
import Ur.Noun.Core
@ -100,7 +100,7 @@ mix = xor
-- Murmur3
muk ∷ Nat → Nat → Nat → Nat
muk seed len =
fromIntegral . murmur3 (word32 seed) . resize . view atomBytes
fromIntegral . murmur3 (word32 seed) . resize . atomBytes
where
resize ∷ ByteString → ByteString
resize buf =

2
pkg/hs/king/lib/Ur/Vere/Dawn.hs
View File

@ -27,7 +27,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import qualified Network.Ethereum.Ens as Ens
import qualified Network.HTTP.Client as C
import qualified Ur.Azimuth as AZ
import qualified Urbit.Azimuth as AZ
import qualified Urbit.Ob as Ob
-- During boot, use the infura provider

2
pkg/hs/king/lib/Ur/Vere/Pier.hs
View File

@ -56,7 +56,7 @@ setupPierDirectory shipPath = do
-- Load pill into boot sequence. -----------------------------------------------
genEntropy :: RIO e Word512
genEntropy = fromIntegral . view (from atomBytes) <$> io (Ent.getEntropy 64)
genEntropy = fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
generateBootSeq :: Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
generateBootSeq ship Pill{..} lite boot = do

6
pkg/hs/king/lib/Ur/Vere/Serf.hs
View File

@ -262,11 +262,7 @@ recvBytes serf =
recvAtom :: HasLogFunc e => Serf e -> RIO e Atom
recvAtom w = do
len <- recvLen w
bs <- recvBytes w len
pure (packAtom bs)
where
packAtom :: ByteString -> Atom
packAtom = view (from atomBytes)
bytesAtom <$> recvBytes w len
cordText :: Cord -> Text
cordText = T.strip . unCord

2
pkg/hs/king/lib/Ur/Vere/Term.hs
View File

@ -563,7 +563,7 @@ term (tsize, Client{..}) shutdownSTM king enqueueEv =
handleFsWrite :: Blit -> RIO e ()
handleFsWrite (Sag path noun) = performPut path (jamBS noun)
handleFsWrite (Sav path atom) = performPut path (atom ^. atomBytes)
handleFsWrite (Sav path atom) = performPut path (atomBytes atom)
handleFsWrite _ = pure ()
performPut :: Path -> ByteString -> RIO e ()

3
pkg/hs/king/package.yaml
View File

@ -102,7 +102,8 @@ dependencies:
- unliftio
- unliftio-core
- unordered-containers
- ur-azimuth
- urbit-atom
- urbit-azimuth
- urbit-hob
- utf8-string
- vector

2
pkg/hs/king/test/DawnTests.hs
View File

@ -16,7 +16,7 @@ import qualified Urbit.Ob as Ob
-- +shas, +shaf, etc. were actually calculated correctly.
cordToAtomBytes :: Text -> ByteString
cordToAtomBytes t = cordToAtom t ^. atomBytes
cordToAtomBytes = atomBytes . cordToAtom
cordToAtom :: Text -> Atom
cordToAtom t = case cordToUW (Cord t) of

3
pkg/hs/stack.yaml
View File

@ -5,7 +5,8 @@ packages:
- lmdb-static
- proto
- terminal-progress-bar
- ur-azimuth
- urbit-atom
- urbit-azimuth
extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38

1
pkg/hs/ur-azimuth/.gitignore vendored
View File

@ -1 +0,0 @@
ur-azimuth.cabal

1
pkg/hs/urbit-atom/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
urbit-atom.cabal

0
pkg/hs/ur-azimuth/LICENSE → pkg/hs/urbit-atom/LICENSE
View File

61
pkg/hs/urbit-atom/lib/Urbit/Atom.hs Normal file
View File

@ -0,0 +1,61 @@
{-|
Atom implementation with fast conversions between bytestrings
and atoms.
-}
module Urbit.Atom
( Atom
, atomBytes, bytesAtom
, atomWords, wordsAtom
, utf8Atom, atomUtf8, atomUtf8Exn, atomUtf8Lenient
) where
import Prelude
import Data.ByteString (ByteString)
import Data.Vector.Primitive (Vector)
import GHC.Natural (Natural)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import qualified Urbit.Atom.Internal as I
--------------------------------------------------------------------------------
type Atom = Natural
--------------------------------------------------------------------------------
-- | Cast an atom to a vector. Does not copy.
atomWords :: Atom → Vector Word
atomWords = I.natWords
-- | Cast a vector to an atom. Does not copy unless given a slice.
wordsAtom :: Vector Word → Atom
wordsAtom = I.wordsNat
-- | Dump an atom to a bytestring.
atomBytes ∷ Atom → ByteString
atomBytes = I.pillBytes . I.natPill
-- | Load a bytestring into an atom.
bytesAtom ∷ ByteString → Atom
bytesAtom = I.pillNat . I.bytesPill
-- | Encode a utf8-encoded atom from text.
utf8Atom ∷ T.Text → Atom
utf8Atom = bytesAtom . T.encodeUtf8
-- | Interpret an atom as utf8 text.
atomUtf8 ∷ Atom → Either T.UnicodeException T.Text
atomUtf8 = T.decodeUtf8' . atomBytes
-- | Interpret an atom as utf8 text, throwing an exception on bad unicode.
atomUtf8Exn ∷ Atom → T.Text
atomUtf8Exn = T.decodeUtf8 . atomBytes
-- | Interpret an atom as utf8 text, replacing bad unicode characters.
atomUtf8Lenient ∷ Atom → T.Text
atomUtf8Lenient = T.decodeUtf8With T.lenientDecode . atomBytes

223
pkg/hs/urbit-atom/lib/Urbit/Atom/Internal.hs Normal file
View File

@ -0,0 +1,223 @@
{-|
Atom implementation with fast conversions between bytestrings
and atoms.
TODO Support 32-bit archetectures.
TODO Support Big Endian.
-}
module Urbit.Atom.Internal where
import Prelude
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.ByteString (ByteString)
import Data.Vector.Primitive (Vector(..))
import Data.Word (Word8)
import GHC.Exts (Ptr(Ptr), sizeofByteArray#)
import GHC.Int (Int(..))
import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
import GHC.Integer.GMP.Internals (indexBigNat#)
import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat)
import GHC.Natural (Natural(..))
import GHC.Prim (clz#, minusWord#, plusWord#)
import GHC.Prim (Word#, int2Word#, subIntC#, timesWord#)
import GHC.Word (Word(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.Primitive.ByteArray as Prim
import qualified Data.Primitive.Types as Prim
import qualified Data.Vector.Primitive as VP
import qualified Foreign.ForeignPtr.Unsafe as Ptr
--------------------------------------------------------------------------------
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# :: Natural -> Word#
atomBitWidth# (NatS# gl) = wordBitWidth# gl
atomBitWidth# (NatJ# bn) = bigNatBitWidth# bn
bitWidth :: Num a => Natural -> 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 = pillBytes x == pillBytes y
instance Show Pill where
show = show . pillBytes
--------------------------------------------------------------------------------
strip :: ByteString → ByteString
strip buf = BS.take (len - go 0 (len - 1)) buf
where
len = BS.length buf
go n i | i < 0 = n
| 0 == BS.unsafeIndex buf i = go (n+1) (i-1)
| otherwise = n
pillBytes :: Pill -> ByteString
pillBytes = strip . unPill
bytesPill :: ByteString -> Pill
bytesPill = Pill . strip
--------------------------------------------------------------------------------
{-
Cast a BigNat to a vector without a copy.
-}
bigNatWords ∷ BigNat → Vector Word
bigNatWords (BN# bArr) =
Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
(Prim.ByteArray bArr)
{-|
Cast a vector to a BigNat. This will not copy.
TODO Don't crash if given a slice.
-}
wordsBigNat ∷ Vector Word → BigNat
wordsBigNat v@(Vector off (I# len) (Prim.ByteArray buf)) =
case VP.length v of
0 -> zeroBigNat
1 -> case VP.unsafeIndex v 0 of W# w -> wordToBigNat w
n -> if off /= 0 then error "words2Nat: bad-vec" else
byteArrayToBigNat# buf len
{-|
More careful version of `wordsBigNat`, but not yet tested.
Cast a vector to a BigNat. This will not copy unless input is a slice.
Note that the length of the vector is in words, and the length passed
to `byteArrayToBigNat#` is also in words.
-}
wordsBigNat' ∷ Vector Word → BigNat
wordsBigNat' v =
case VP.length v of
0 -> zeroBigNat
1 -> wordToBigNat w where W# w = VP.unsafeIndex v 0
n -> if offset v == 0 then extract v else extract (VP.force v)
where
offset (Vector off _ _) = off
extract (Vector _ (I# len) (Prim.ByteArray buf)) =
byteArrayToBigNat# buf len
--------------------------------------------------------------------------------
-- | Cast a nat to a vector (no copy)
natWords :: Natural → Vector Word
natWords = bigNatWords . natBigNat
-- | Cast a vector to a nat (no copy)
wordsNat ∷ Vector Word → Natural
wordsNat = bigNatNat . wordsBigNat
-- | Cast a Nat to a BigNat (no copy).
natBigNat ∷ Natural → BigNat
natBigNat (NatS# w) = wordToBigNat w
natBigNat (NatJ# bn) = bn
-- | Cast a BigNat to a Nat (no copy).
bigNatNat ∷ BigNat → Natural
bigNatNat bn =
case sizeofBigNat# bn of
0# -> 0
1# -> NatS# (bigNatToWord bn)
_ -> NatJ# bn
--------------------------------------------------------------------------------
-- | TODO This assumes 64-bit words
wordBytes ∷ Word → ByteString
wordBytes wor =
BS.reverse $ BS.pack $ go 0 []
where
go i acc | i >= 8 = acc
go i acc | otherwise = go (i+1) (fromIntegral (shiftR wor (i*8)) : acc)
-- | TODO This assumes 64-bit words
bytesFirstWord ∷ ByteString → Word
bytesFirstWord buf = go 0 0
where
top = min 8 (BS.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)
--------------------------------------------------------------------------------
pillWords ∷ Pill → Vector Word
pillWords = bsToWords . pillBytes
wordsPill ∷ Vector Word → Pill
wordsPill = bytesPill . vecBytes . wordsToBytes
--------------------------------------------------------------------------------
wordsToBytes :: Vector Word -> Vector Word8
wordsToBytes (Vector off sz buf) =
Vector (off*8) (sz*8) buf
bsToWords :: ByteString -> Vector Word
bsToWords bs =
VP.generate (1 + BS.length bs `div` 8) $ \i ->
bytesFirstWord (BS.drop (i*8) bs)
--------------------------------------------------------------------------------
vecBytes :: Vector Word8 -> ByteString
vecBytes (Vector off sz buf) =
unsafePerformIO $ do
fp <- BS.mallocByteString sz
let Ptr a = Ptr.unsafeForeignPtrToPtr fp -- Safe b/c returning fp
Prim.copyByteArrayToAddr (Prim.Addr a) buf 0 sz
pure (BS.PS fp off sz)
bytesVec ∷ ByteString → Vector Word8
bytesVec bs = VP.generate (BS.length bs) (BS.index bs)
--------------------------------------------------------------------------------
natPill ∷ Natural → Pill
natPill = wordsPill . natWords
pillNat ∷ Pill → Natural
pillNat = wordsNat . bsToWords . pillBytes
--------------------------------------------------------------------------------

66
pkg/hs/urbit-atom/package.yaml Normal file
View File

@ -0,0 +1,66 @@
name: urbit-atom
version: 0.10.1
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- bytestring
- ghc-prim
- integer-gmp
- primitive
- text
- vector
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

1
pkg/hs/urbit-azimuth/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
urbit-azimuth.cabal

21
pkg/hs/urbit-azimuth/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

2
pkg/hs/ur-azimuth/Ur/Azimuth.hs → pkg/hs/urbit-azimuth/Urbit/Azimuth.hs
View File

@ -1,4 +1,4 @@
module Ur.Azimuth where
module Urbit.Azimuth where
import Network.Ethereum.Contract.TH

0
pkg/hs/ur-azimuth/azimuth.json → pkg/hs/urbit-azimuth/azimuth.json
View File

2
pkg/hs/ur-azimuth/package.yaml → pkg/hs/urbit-azimuth/package.yaml
View File

@ -1,4 +1,4 @@
name: ur-azimuth
name: urbit-azimuth
version: 0.10.1
license: MIT
license-file: LICENSE