urbit-atom: Wrote tests and fixed an edge-case.

pkg/hs/urbit-atom/app/Main.hs

@@ -2,7 +2,7 @@ module Main where
 
 import Prelude
 import Urbit.Atom
-import Urbit.Atom.Internal (bit, byt)
+import Urbit.Atom.Fast (bit, byt)
 
 main :: IO ()
 main = do

pkg/hs/urbit-atom/lib/Urbit/Atom.hs

@@ -25,7 +25,7 @@ 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
+import qualified Urbit.Atom.Fast          as A
 
 
 --------------------------------------------------------------------------------
@@ -36,19 +36,19 @@ type Atom = Natural
 
 -- | Cast an atom to a vector. Does not copy.
 atomWords :: Atom -> Vector Word
-atomWords = I.natWords
+atomWords = A.natWords
 
 -- | Cast a vector to an atom. Does not copy unless given a slice.
 wordsAtom :: Vector Word -> Atom
-wordsAtom = I.wordsNat
+wordsAtom = A.wordsNat
 
 -- | Dump an atom to a bytestring.
 atomBytes :: Atom -> ByteString
-atomBytes = I.pillBytes . I.natPill
+atomBytes = A.pillBytes . A.natPill
 
 -- | Load a bytestring into an atom.
 bytesAtom :: ByteString -> Atom
-bytesAtom = I.pillNat . I.bytesPill
+bytesAtom = A.pillNat . A.bytesPill
 
 -- | Encode a utf8-encoded atom from text.
 utf8Atom :: T.Text -> Atom

pkg/hs/urbit-atom/lib/Urbit/Atom/Fast.hs

@@ -7,7 +7,7 @@
     TODO Support Big Endian.
 -}
 
-module Urbit.Atom.Internal where
+module Urbit.Atom.Fast where
 
 import Prelude
 
@@ -19,7 +19,7 @@ import Data.Word                 (Word8)
 import GHC.Exts                  (Ptr(Ptr), sizeofByteArray#)
 import GHC.Exts                  (Int(..))
 import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
-import GHC.Integer.GMP.Internals (indexBigNat#)
+import GHC.Integer.GMP.Internals (isZeroBigNat, indexBigNat#)
 import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat)
 import GHC.Natural               (Natural(..))
 import GHC.Prim                  (Int#, clz#, minusWord#, plusWord#)
@@ -123,7 +123,8 @@ bytesPill = Pill . strip
     Cast a BigNat to a vector without a copy.
 -}
 bigNatWords :: BigNat -> Vector Word
-bigNatWords (BN# bArr) =
+bigNatWords bn | isZeroBigNat bn = mempty
+bigNatWords bn@(BN# bArr) =
   Vector 0 (I# (sizeofByteArray# bArr) `div` BYT) (Prim.ByteArray bArr)
 
 {-|

pkg/hs/urbit-atom/package.yaml

@@ -3,36 +3,50 @@ version: 0.10.1
 license: MIT
 license-file: LICENSE
 
+ghc-options:
+  # -fwarn-incomplete-patterns
+  # -fwarn-unused-binds
+  # -fwarn-unused-imports
+  - -Werror
+  - -O2
+
 library:
   source-dirs: lib
-  ghc-options:
+  dependencies:
-    - -fwarn-incomplete-patterns
+    - base == 4.12.0.0
-    - -fwarn-unused-binds
+    - bytestring == 0.10.8.2
-    - -fwarn-unused-imports
+    - ghc-prim == 0.5.3
-    - -Werror
+    - integer-gmp == 1.0.2.0
-    - -O2
+    - primitive == 0.6.4.0
+    - text == 1.2.3.1
+    - vector == 0.12.0.3
+
+tests:
+  urbit-atom-tests:
+    source-dirs: test
+    main: Main.hs
+    ghc-options: "-threaded -rtsopts -with-rtsopts=-N"
+    dependencies:
+      - base
+      - bytestring
+      - classy-prelude
+      - QuickCheck
+      - tasty
+      - tasty-hunit
+      - tasty-quickcheck
+      - tasty-th
+      - urbit-atom
+      - vector
 
 executables:
   urbit-atom:
     source-dirs: app
     main: Main.hs
+    ghc-options: "-threaded -rtsopts -with-rtsopts=-N"
     dependencies:
+      - base
+      - classy-prelude
       - urbit-atom
-    ghc-options:
-      - -threaded
-      - -rtsopts
-      - -static
-      - -O2
-      - "-with-rtsopts=-N"
-
-dependencies:
-  - base == 4.12.0.0
-  - bytestring == 0.10.8.2
-  - ghc-prim == 0.5.3
-  - integer-gmp == 1.0.2.0
-  - primitive == 0.6.4.0
-  - text == 1.2.3.1
-  - vector == 0.12.0.3
 
 default-extensions:
   - ApplicativeDo

pkg/hs/urbit-atom/test/Main.hs

@@ -1,74 +1,106 @@
+{-# OPTIONS_GHC -Wno-deprecations #-}
+
+
 module Main (main) where
 
 --------------------------------------------------------------------------------
 
-tryLoadPill :: PillFile -> IO Atom
+import ClassyPrelude         hiding (Vector)
-tryLoadPill pill = do
+import Numeric.Natural
-    a@(MkAtom nat) <- loadAtom (show pill)
+import Test.QuickCheck       hiding ((.&.))
-    putStrLn "loaded"
+import Test.Tasty
-    print (a > 0)
+import Test.Tasty.QuickCheck
-    putStrLn "evaled"
+import Test.Tasty.TH
-    print (take 10 $ VP.toList $ nat ^. natWords)
-    pure a
 
-tryPackPill :: PillFile -> IO ()
+import Data.Vector.Primitive (Vector)
-tryPackPill pf = do
+
-  atm <- tryLoadPill pf
+import qualified Data.ByteString        as BS
-  print $ length (atm ^. pill . pillBS)
+import qualified Data.ByteString.Unsafe as BS
+import qualified Data.Vector.Primitive  as VP
+import qualified Urbit.Atom             as F
+import qualified Urbit.Atom.Slow        as S
 
 
--- Tests -----------------------------------------------------------------------
+-- Instances -------------------------------------------------------------------
+
+instance Arbitrary Natural where
+  arbitrary = fromInteger . abs <$> arbitrary
 
 instance Arbitrary ByteString where
-  arbitrary = fromList <$> arbitrary
+  arbitrary = BS.pack <$> arbitrary
 
-instance Arbitrary Pill where
+instance (Prim a, Arbitrary a) => Arbitrary (Vector a) where
-  arbitrary = Pill <$> arbitrary
+  arbitrary = VP.fromList <$> arbitrary
 
-instance Arbitrary BigNat where
-  arbitrary = view naturalBigNat <$> arbitrary
 
-instance Show BigNat where
+-- Utils -----------------------------------------------------------------------
-  show = show . NatJ#
 
---------------------------------------------------------------------------------
+stripBytes :: ByteString -> ByteString
+stripBytes 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
 
-testIso :: Eq a => Iso' a b -> a -> Bool
+stripWords :: Vector Word -> Vector Word
-testIso iso x = x == (x ^. iso . from iso)
+stripWords vec = VP.take (len - go 0 (len - 1)) vec
+ where
+  len = VP.length vec
+  go n i | i < 0                     = n
+         | 0 == VP.unsafeIndex vec i = go (n + 1) (i - 1)
+         | otherwise                 = n
 
-roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool)
+dumpLoad :: Eq i => (i -> o) -> (o -> i) -> (i -> Bool)
-roundTrip dump load x = x == load (dump x)
+dumpLoad dump load x = x == load (dump x)
 
-equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool)
+loadDump :: Eq o => (o -> i) -> (i -> o) -> (o -> o) -> (o -> Bool)
-equiv f g x = f x == g x
+loadDump load dump norm x = norm x == dump (load x)
 
-check :: Atom -> Atom
-check = toAtom . (id :: Integer -> Integer) . fromAtom
 
---------------------------------------------------------------------------------
+-- Test Reference Implementation -----------------------------------------------
 
-prop_packWordSane = equiv (view packedWord) dumbPackWord . fromList
+prop_atom_bytes_roundtrip :: Natural -> Bool
-prop_packWord     = testIso (from packedWord)
+prop_atom_bytes_roundtrip = dumpLoad S.natBytes S.bytesNat
-prop_unpackWord   = roundTrip (view packedWord)
-                              (strip . view (from packedWord))
-                  . strip
-                  . take 8
 
-prop_unpackBigNat = testIso bigNatWords
+prop_atom_words_roundtrip :: Natural -> Bool
+prop_atom_words_roundtrip = dumpLoad S.natWords S.wordsNat
 
-prop_packBigNat   = roundTrip (view (from bigNatWords) . VP.fromList)
+prop_bytes_atom_roundtrip :: ByteString -> Bool
-                              (strip . VP.toList . view bigNatWords)
+prop_bytes_atom_roundtrip = loadDump S.bytesNat S.natBytes stripBytes
-                  . strip
 
-prop_implodeBytes = roundTrip (view pillWords) (view (from pillWords))
+prop_words_atom_roundtrip :: Vector Word -> Bool
+prop_words_atom_roundtrip = loadDump S.wordsNat S.natWords stripWords
 
-prop_explodeBytes = roundTrip (view (from pillWords) . VP.fromList)
-                              (strip . VP.toList . view pillWords)
-                  . strip
 
-prop_packAtomSane = equiv (view (from pill)) dumbPackAtom . Pill . fromList
+-- Test Fast Implementation ----------------------------------------------------
-prop_unpackAtom   = roundTrip (view pill) (view (from pill))
+
-prop_packAtom     = roundTrip (view (from pill)) (view pill) . Pill . strip
+prop_fast_atom_bytes_roundtrip :: Natural -> Bool
+prop_fast_atom_bytes_roundtrip = dumpLoad F.atomBytes F.bytesAtom
+
+prop_fast_atom_words_roundtrip :: Natural -> Bool
+prop_fast_atom_words_roundtrip = dumpLoad F.atomWords F.wordsAtom
+
+prop_fast_bytes_atom_roundtrip :: ByteString -> Bool
+prop_fast_bytes_atom_roundtrip = loadDump F.bytesAtom F.atomBytes stripBytes
+
+prop_fast_words_atom_roundtrip :: Vector Word -> Bool
+prop_fast_words_atom_roundtrip = loadDump F.wordsAtom F.atomWords stripWords
+
+
+-- Fast and Reference Implementations are the Same -----------------------------
+
+prop_fast_words_atom_correct :: Vector Word -> Bool
+prop_fast_words_atom_correct x = F.wordsAtom x == S.wordsNat x
+
+prop_fast_atom_words_correct :: Natural -> Bool
+prop_fast_atom_words_correct x = F.atomWords x == S.natWords x
+
+prop_fast_bytes_atom_correct :: ByteString -> Bool
+prop_fast_bytes_atom_correct x = F.bytesAtom x == S.bytesNat x
+
+prop_fast_atom_bytes_correct :: Natural -> Bool
+prop_fast_atom_bytes_correct x = F.atomBytes x == S.natBytes x
 
 
 --------------------------------------------------------------------------------

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

@@ -10,7 +10,7 @@ module Urbit.Noun.Jam (jam, jamBS) where
 import ClassyPrelude hiding (hash)
 
 import Urbit.Atom
-import Urbit.Atom.Internal
+import Urbit.Atom.Fast
 import Urbit.Noun.Core
 
 import Data.Bits                 (clearBit, setBit, shiftL, shiftR, (.|.))