Merge branch 'bs/portable-urbit-atom' of github.com:urbit/urbit into bs/portable-urbit-atom

pkg/hs/urbit-atom/.gitignore

@@ -1 +1,2 @@
 urbit-atom.cabal
+dist-newstyle/

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

@@ -0,0 +1,30 @@
+module Main where
+
+import Prelude
+import Urbit.Atom
+import Urbit.Atom.Internal (bit, byt)
+
+main :: IO ()
+main = do
+  print (bit, byt)
+  f "a"
+  f "x"
+  f "aa"
+  f "ax"
+  f "aaa"
+  f "aax"
+  f "aaaa"
+  f "aaax"
+  f "aaaaa"
+  f "aaaax"
+  f "aaaaaa"
+  f "aaaaax"
+  f "aaaaaaa"
+  f "aaaaaax"
+  f "aaaaaaaa"
+  f "aaaaaaax"
+  f "aaaaaaaaa"
+  f "aaaaaaaax"
+
+ where
+  f x = print (x, utf8Atom x)

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

@@ -50,6 +50,12 @@ import qualified Foreign.ForeignPtr.Unsafe as Ptr
 #error WORD_SIZE_IN_BITS must be either 32 or 64
 #endif
 
+bit :: Word
+bit = BIT
+
+byt :: Word
+byt = BYT
+
 
 --------------------------------------------------------------------------------
 

pkg/hs/urbit-atom/package.yaml

@@ -12,14 +12,27 @@ library:
     - -Werror
     - -O2
 
+executables:
+  urbit-atom:
+    source-dirs: app
+    main: Main.hs
+    dependencies:
+      - urbit-atom
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -static
+      - -O2
+      - "-with-rtsopts=-N"
+
 dependencies:
-  - base
-  - bytestring
-  - ghc-prim
-  - integer-gmp
-  - primitive
-  - text
-  - vector
+  - 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

@@ -0,0 +1,77 @@
+module Main (main) where
+
+--------------------------------------------------------------------------------
+
+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)