master..f18df57 · nock-hs

bench/Main.hs+1−2

@@ -10,7 +10,6 @@ import Nock.Parser (noun)

1010import System.FilePath.Posix

1111import System.Process.Typed

1212import Test.Tasty.Golden (findByExtension)

13−import Effectful

1413

1514main :: IO ()

1615main = do

@@ -23,5 +22,5 @@ main = do

2322 $ proc "urbit" ["eval"]

2423 & setStdin (byteStringInput hoon)

2524 & setStderr nullStream

26− pure $ bench (takeBaseName hoonFile) $ nf (runPureEff . tar) $ cell (atom 0) nock

25+ pure $ bench (takeBaseName hoonFile) $ nf tar $ cell (atom 0) nock

2726 defaultMain benchmarks

flake.lock+3−3

@@ -19,11 +19,11 @@

1919 },

2020 "nixpkgs": {

2121 "locked": {

22− "lastModified": 1746141548,

23− "narHash": "sha256-IgBWhX7A2oJmZFIrpRuMnw5RAufVnfvOgHWgIdds+hc=",

22+ "lastModified": 1737062831,

23+ "narHash": "sha256-Tbk1MZbtV2s5aG+iM99U8FqwxU/YNArMcWAv6clcsBc=",

2424 "owner": "NixOS",

2525 "repo": "nixpkgs",

26− "rev": "f02fddb8acef29a8b32f10a335d44828d7825b78",

26+ "rev": "5df43628fdf08d642be8ba5b3625a6c70731c19c",

2727 "type": "github"

2828 },

2929 "original": {

flake.nix+1−1

@@ -8,7 +8,7 @@

88 let

99 supportedSystems =

1010 [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];

11− compilerVersion = "984";

11+ compilerVersion = "966";

1212 in flake-utils.lib.eachSystem supportedSystems (system:

1313 let pkgs = import nixpkgs { inherit system; };

1414 in {

package.yaml−6

@@ -20,9 +20,6 @@ dependencies:

2020 - deepseq

2121 - effectful

2222 - unordered-containers

23− - murmur3

24− - file-embed

25− - mtl

2623library:

2724 source-dirs: src

2825

@@ -36,7 +33,6 @@ benchmarks:

3633 main: bench/Main.hs

3734

3835 dependencies:

39− - effectful

4036 - tasty

4137 - nock

4238ghc-options: >

@@ -93,5 +89,3 @@ tests:

9389 - tasty-hspec

9490 - hspec

9591 - effectful

96− - tasty-quickcheck

97− - tasty-hunit

res/dec.jamdeleted−11

@@ -1,11 +0,0 @@

1−�~[Y��lea��K��qpr�r�qpy�r�v�rpwpz�6x=�;89x9�<�98;�;�� r��!�.�b�46T�A�8��-a>̡bl��d� Z�C�:��0׳

2−� Xsql��`q؅�P)&�o��d� ZP>$� �A2d-��D;$��1H��]�� 9��0ׇlf�,l��:v��~A�x��.܆J1!\B:H��],H6��Cq�D;a|�`�9��b��5�t�FF��CV��;sq؅�p�� b��d �r8ɐA�� R��!�Y�I7xlt��L<�`��f��,n�~C��889x:�=x:89x9h\<� �^.�v��C�]� ��p�n��`C��.$��1H��p�Ϊ��q(�d� ZP>$�?��<Ի�\b��5�t�Gf'��C~A��\vA� |9��!Yq��f�pҍ^[~81X��2�8��`A20*�C�B9\0�lf '�8��ه3��_l��'�lf '�8��3��avC�bC�=T��],�p*��P)�]؅]� �␈9��,�d� Z/$n� � 2��P�� ذ�3H��~�`18dk��9��![s(��lf '�8�ѡ�3��a��C

3−�fr��f�pҍ�z81X��;sq� ��Ú�!�Y�I7xgt��L<�`�_l�3�ݐ�8$+1��N�q�kKsg�!�/6��7lL��ͬ��7�p&b0��`Ý��56�?��A�8>^.N.>��0ׇ�!-��j$C��n8��x�D{H�.�C1��N�q��g�!+6T��A��=T��P$�[��A��A2P�18�� ;փd� Z�áu�`��m8�̡bb��`��J�86T��

4−�!V�7��V��J�\��%��]+6��9� X��A2d-�� X��!�ha'�>\0�` �>H��p�V�18�`��A��R,��ݰ3��n�J7T�C��a�w� ��~��!� ��` �6��pwq��` �ɐA��a��CV��

5−� X��_�C�pN*Ƅ��A��`�7��-�szlXV:��V�18�`lX�_*�� X� ;�+6T��9=~á8$w��P<l��~�7+�b� ذB�8�0]� U�i~Xa?��A�a�q��Rz,��]� ��p��j=� ��P?mkv�6\��Jqh�16��a��C*�� X؅ݰ3}X3�P1��~��

6−� +��` ��b��V�18�`A��R,��pg� ��a��

7−�!�`C�X��P<��

8−�!� +�`C�X��P\~áu��C+�b��`�

9−�� P)��nؙ^C��o8��d��:��M�C��A��ɡ��a��C��A�a��~��`�

10−�� XC��ڹ6�cq��{� X� ��a��~��!�`�

11−�� P)��nؙ��e��~��~��!� �P)�]��ȡblh�:��-FcC��av�6�C��P)�aC��>��|��d� Z�A� 8W�� 2�vá5��C��s��!�Y�I7xca��L<�`��a7\��ǰ҂�ǰ�� W��],H��P$C��n��]x̰��k��]�C��l�D;$��á8H��]� ;��`A2�á8H��ݐ�9t�=\0�oع�8�!�ha~�� 2��`C�C7�C]x��9�`3k8��<�� P)�]� �Z7T�C[� �v� �_7ԏ�l�D;64�$C��.��A��1��v.��.΃d� Z؅߰sy�d{��{�`�!�Y�I7xma��L<�`��e�

src/Data/HashMap/Monadic.hsdeleted−155

@@ -1,155 +0,0 @@

1−module Data.HashMap.Monadic (MEq (..), insert, lookup) where

2−

3−import Control.Monad.ST (runST)

4−import Data.Bits

5−import Data.Functor ((<&>))

6−import Data.HashMap.Internal

7− ( Hash,

8− HashMap (..),

9− Leaf (..),

10− bitmapIndexedOrFull,

11− collision,

12− hash,

13− index,

14− mask,

15− nextShift,

16− ptrEq,

17− sparseIndex,

18− two,

19− update32,

20− )

21−import Data.HashMap.Internal.Array qualified as A

22−import Data.Hashable

23−import Prelude hiding (lookup)

24−

25−class MEq x m where

26− (===) :: x -> x -> m Bool

27−

28−insert :: (MEq k m, Hashable k, Monad m) => k -> v -> HashMap k v -> m (HashMap k v)

29−insert k v m = insert' (Data.HashMap.Internal.hash k) k v m

30−

31−insert' :: forall m k v. (MEq k m, Monad m) => Hash -> k -> v -> HashMap k v -> m (HashMap k v)

32−insert' h0 k0 v0 m0 = go h0 k0 v0 0 m0

33− where

34− -- go :: _ -> _ -> _ -> _ -> _ -> m _

35− go !h !k x !_ Empty = pure @m $ Leaf h (L k x)

36− go h k x s t@(Leaf hy l@(L ky y))

37− | hy == h = do

38− ky === k >>= \eq ->

39− if eq

40− then

41− if x `ptrEq` y

42− then pure @m t

43− else pure @m $ Leaf h (L k x)

44− else pure $ collision h l (L k x)

45− | otherwise = pure $ runST (two s h k x hy t)

46− go h k x s t@(BitmapIndexed b ary)

47− | b .&. m == 0 =

48− let !ary' = A.insert ary i $! Leaf h (L k x)

49− in pure $ bitmapIndexedOrFull (b .|. m) ary'

50− | otherwise = do

51− let !st = A.index ary i

52− !st' <- go h k x (nextShift s) st

53− if st' `ptrEq` st

54− then pure t

55− else pure $ BitmapIndexed b (A.update ary i st')

56− where

57− m = mask h s

58− i = sparseIndex b m

59− go h k x s t@(Full ary) = do

60− let !st = A.index ary i

61− !st' <- go h k x (nextShift s) st

62− if st' `ptrEq` st

63− then pure t

64− else pure $ Full (update32 ary i st')

65− where

66− i = index h s

67− go h k x s t@(Collision hy v)

68− | h == hy = Collision h <$> (updateOrSnocWith (\a _ -> (# a #)) k x v)

69− | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)

70−

71−updateOrSnocWith ::

72− (MEq k m, Monad m) =>

73− (v -> v -> (# v #)) ->

74− k ->

75− v ->

76− A.Array (Leaf k v) ->

77− m (A.Array (Leaf k v))

78−updateOrSnocWith f = updateOrSnocWithKey (const f)

79−{-# INLINEABLE updateOrSnocWith #-}

80−

81−updateOrSnocWithKey ::

82− (MEq k m, Monad m) =>

83− (k -> v -> v -> (# v #)) ->

84− k ->

85− v ->

86− A.Array (Leaf k v) ->

87− m (A.Array (Leaf k v))

88−updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0)

89− where

90− go !k v !ary !i !n

91− -- Not found, append to the end.

92− | i >= n = pure $ A.snoc ary $ L k v

93− | otherwise =

94− let L kx y = A.index ary i

95− (# v2 #) = f k v y

96− in k === kx >>= \eq ->

97− if eq

98− then pure $ A.update ary i (L k v2)

99− else go k v ary (i + 1) n

100−

101−lookup :: (MEq k m, Hashable k, Monad m) => k -> HashMap k v -> m (Maybe v)

102−lookup k m = lookupCont Nothing (\v _i -> Just v) (Data.HashMap.Internal.hash k) k 0 m

103−

104−lookupCont ::

105− forall m r k v.

106− (MEq k m, Monad m) =>

107− r -> -- Absent continuation

108− (v -> Int -> r) -> -- Present continuation

109− Hash -> -- The hash of the key

110− k ->

111− Int -> -- The offset of the subkey in the hash.

112− HashMap k v ->

113− m r

114−lookupCont absent present !h0 !k0 !s0 !m0 = go h0 k0 s0 m0

115− where

116− go :: Hash -> k -> Int -> HashMap k v -> m r

117− go !_ !_ !_ Empty = pure absent

118− go h k _ (Leaf hx (L kx x))

119− | h == hx =

120− k === kx <&> \eq ->

121− if eq

122− then present x (-1)

123− else absent

124− | otherwise = pure absent

125− go h k s (BitmapIndexed b v)

126− | b .&. m == 0 = pure absent

127− | otherwise =

128− go h k (nextShift s) (A.index v (sparseIndex b m))

129− where

130− m = mask h s

131− go h k s (Full v) =

132− go h k (nextShift s) (A.index v (index h s))

133− go h k _ (Collision hx v)

134− | h == hx = lookupInArrayCont absent present k v

135− | otherwise = pure absent

136−

137−lookupInArrayCont ::

138− forall m r k v.

139− (MEq k m, Monad m) =>

140− r ->

141− (v -> Int -> r) ->

142− k ->

143− A.Array (Leaf k v) ->

144− m r

145−lookupInArrayCont absent present k0 ary0 = go k0 ary0 0 (A.length ary0)

146− where

147− go :: k -> A.Array (Leaf k v) -> Int -> Int -> m r

148− go !k !ary !i !n

149− | i >= n = pure absent

150− | otherwise = case A.index ary i of

151− (L kx v) ->

152− k === kx >>= \eq ->

153− if eq

154− then pure $ present v i

155− else go k ary (i + 1) n

src/Nock.hs+4−4

@@ -43,8 +43,8 @@ lus ~(Atom nat _) = atom $ case nat of

4343 (# l, c #) -> NB (bigNatFromWord2# (int2Word# c) l)

4444 (NB n) -> NB (bigNatAddWord# n 1##)

4545

46−tis :: Noun -> Noun -> Eff es Noun

47−tis lhs rhs = pure $ if lhs == rhs then sig else one

46+tis :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Noun -> Eff es Noun

47+tis lhs rhs = nounEq lhs rhs <&> \eq -> if eq then sig else one

4848

4949fas# :: Word# -> Noun -> Noun

5050fas# lhs rhs =

@@ -84,10 +84,10 @@ hax n b c =

8484 then hax a (cell (fas (n - 1) c) b) c

8585 else hax a (cell b (fas (n + 1) c)) c

8686

87−tar :: Noun -> Eff es Noun

87+tar :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Eff es Noun

8888tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject

8989

90−tar' :: Noun -> Noun -> Noun -> Eff es Noun

90+tar' :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Noun -> Noun -> Eff es Noun

9191tar' b c subject = case b of

9292 Cell x y _ -> case c of

9393 ~(Cell l k _) -> cell <$> tar' x y subject <*> tar' l k subject

src/Nock/Cue.hsdeleted−98

@@ -1,98 +0,0 @@

1−module Nock.Cue (cue, rub) where

2−

3−import Control.Monad.Trans.Class

4−import Control.Monad.Trans.State

5−import Data.Binary.Bits.BitOrder

6−import Data.Binary.Bits.Get

7−import Data.Binary.Get (runGet)

8−import Data.Bits

9−import Data.ByteString.Lazy (ByteString)

10−import Data.Map (Map)

11−import Data.Map qualified as M

12−import GHC.Base (Int (..), Word (..), Word#, int2Word#, minusWord#, or#, shiftL#, word2Int#)

13−import GHC.Num

14−import Nock.Types

15−

16−type BitParser = StateT (Int, Map Int Noun) BitGet

17−

18−parseBit# :: BitParser Int

19−parseBit# = do

20− (counter, m) <- get

21− b <- lift getBool#

22− put (counter + 1, m)

23− pure b

24−

25−parseBits# :: Word# -> BitParser Natural

26−parseBits# 0## = pure 0

27−parseBits# n = do

28− I# b <- parseBit#

29− rest <- parseBits# (n `minusWord#` 1##)

30− pure $ (rest `shiftL` 1) `naturalOr` NS (int2Word# b)

31−

32−getOffset :: BitParser Int

33−getOffset = fst <$> get

34−

35−getMapping :: BitParser (Map Int Noun)

36−getMapping = snd <$> get

37−

38−putMapping :: Map Int Noun -> BitParser ()

39−putMapping m = do

40− (offset, _) <- get

41− put (offset, m)

42−

43−cue :: ByteString -> Noun

44−cue = runGet (runBitGet . withBitOrder LL . flip evalStateT (0, M.empty) $ cue')

45−

46−cue' :: BitParser Noun

47−cue' = do

48− offset <- getOffset

49− I# isNotAtom <- parseBit#

50− case isNotAtom of

51− 0# -> do

52− a' <- rub'

53− let a = atom a'

54− m <- getMapping

55− putMapping $ M.insert offset a m

56− pure a

57− _ -> do

58− I# isRef <- parseBit#

59− case isRef of

60− 0# -> do

61− x <- cue'

62− y <- cue'

63− let c = cell x y

64− m <- getMapping

65− putMapping $ M.insert offset c m

66− pure c

67− _ -> do

68− ref <- rub'

69− let ref# = case ref of

70− NS w -> I# (word2Int# w)

71− _ -> undefined

72− m <- getMapping

73− case M.lookup ref# m of

74− Nothing -> undefined

75− Just a -> pure a

76−

77−rub :: ByteString -> Natural

78−rub = runGet (runBitGet . withBitOrder LL . flip evalStateT (0, M.empty) $ rub')

79−

80−rub' :: BitParser Natural

81−rub' = do

82− parseBit# >>= \case

83− I# 0# -> do

84− W# lengthOfLength <- countZeros 0

85− lengthBits <- parseBits# lengthOfLength

86− let lengthBits# = case lengthBits of

87− NS w -> w

88− _ -> undefined

89− let lent = lengthBits# `or#` (1## `shiftL#` word2Int# lengthOfLength)

90− parseBits# lent

91− _ -> pure 0

92−

93−countZeros :: Word -> BitParser Word

94−countZeros n = do

95− I# b <- parseBit#

96− case b of

97− 0# -> countZeros (n + 1)

98− _ -> pure n

src/Nock/Jam.hs+97−101

@@ -1,128 +1,124 @@

1−{-# LANGUAGE NoMonomorphismRestriction #-}

1+module Nock.Jam (jam, cue, mat, rub) where

22

3−module Nock.Jam (jam, mat) where

4−

5−import Control.Monad.Identity

6−import Control.Monad.State.Strict (MonadState (..))

73import Control.Monad.Trans.Class

8−import Control.Monad.Trans.State hiding (get, put)

4+import Control.Monad.Trans.State

95import Data.Binary.Bits.BitOrder

10−import Data.Binary.Bits.Put qualified as Put

6+import Data.Binary.Bits.Get

7+import Data.Binary.Bits.Put

8+import Data.Binary.Get (runGet)

119import Data.Binary.Put (runPut)

1210import Data.Bits

1311import Data.ByteString.Lazy (ByteString)

14−import Data.Map.Strict (Map)

15−import Data.Map.Strict qualified as M

16−import GHC.Base (Word (..), Word#, int2Word#, isTrue#, leWord#, plusWord#, timesWord#)

17−import GHC.Int (Int (..))

18−import GHC.Num

12+import Data.Map (Map)

13+import Data.Map qualified as M

14+import Nock

1915import Nock.Types

16+import Numeric.Natural

2017

21−type BitPrinterM = StateT (Natural, Map Noun Natural) Put.BitPut

22−

23−class (MonadState (Natural, Map Noun Natural) m) => BitPrinter m where

24− putBit# :: (BitPrinter m) => Word# -> m ()

25− putBool :: Bool -> m ()

26−

27−instance BitPrinter (StateT (Natural, Map Noun Natural) Identity) where

28− putBit# _ = do

29− (counter, m) <- get

30− put (counter + 1, m)

31− putBool _ = do

32− (counter, m) <- get

33− put (counter + 1, m)

34−

35−instance BitPrinter BitPrinterM where

36− putBit# w = do

37− (counter, m) <- get

38− lift $ Put.putBool# w

39− put (counter + 1, m)

40− putBool b = do

41− (counter, m) <- get

42− lift $ Put.putBool b

43− put (counter + 1, m)

44−

45−getOffset :: (BitPrinter m) => m Natural

46−getOffset = fst <$> get

18+type BitParser = StateT (Int, Map Int Noun) BitGet

4719

48−getMapping :: (BitPrinter m) => m (Map Noun Natural)

49−getMapping = snd <$> get

20+parseBit :: BitParser Bool

21+parseBit = do

22+ (counter, m) <- get

23+ b <- lift getBool

24+ put (counter + 1, m)

25+ pure b

5026

51−putMapping :: (BitPrinter m) => Noun -> Natural -> m ()

52−putMapping idx n = do

53− (offset, m) <- get

54− put (offset, M.insert idx n m)

27+parseBits :: Int -> BitParser [Bool]

28+parseBits 0 = pure []

29+parseBits n = do

30+ b <- parseBit

31+ (b :) <$> parseBits (n - 1)

5532

56−jam :: Noun -> ByteString

57−jam n = runPut . Put.runBitPut . withBitOrder LL . flip evalStateT (0, M.empty) $ jam' n

33+getOffset :: BitParser Int

34+getOffset = fst <$> get

35+

36+cue :: ByteString -> Noun

37+cue = runGet (runBitGet . withBitOrder LL . flip evalStateT (0, M.empty) $ cue')

5838

59−jam' :: (BitPrinter m) => Noun -> m ()

60−jam' n = do

39+cue' :: BitParser Noun

40+cue' = do

6141 offset <- getOffset

62− mapping <- getMapping

63− case M.lookup n mapping of

64− Nothing -> do

65− putMapping n offset

66− case n of

67− (Atom a _) -> do

68− putBit# 0##

69− mat' a

70− (Cell lhs rhs _) -> do

71− putBit# 1##

72− putBit# 0##

73− jam' lhs

74− jam' rhs

75− Just ref -> do

76− case n of

77− Cell {} -> do

78− putBit# 1##

79− putBit# 1##

80− mat' ref

81− (Atom a _) -> do

82− if isTrue# (matSize a `leWord#` matSize ref)

83− then do

84− putBit# 0##

85− mat' a

86− else do

87− putBit# 1##

88− putBit# 1##

89− mat' ref

42+ isNotAtom <- parseBit

43+ case isNotAtom of

44+ False -> do

45+ a' <- rub'

46+ let a = atom a'

47+ (offset, m) <- get

48+ put (offset, M.insert offset a m)

49+ pure a

50+ True -> do

51+ isNotRef <- parseBit

52+ case isNotRef of

53+ False -> do

54+ x <- cue'

55+ y <- cue'

56+ let c = cell x y

57+ (offset, m) <- get

58+ put (offset, M.insert offset c m)

59+ pure c

60+ True -> do

61+ ref <- rub'

62+ (_, m) <- get

63+ case M.lookup (fromIntegral ref) m of

64+ Nothing -> undefined

65+ Just a -> pure a

66+

67+jam :: Noun -> ByteString

68+jam n = runPut . runBitPut . withBitOrder LL $ jam' n

69+

70+jam' :: Noun -> BitPut ()

71+jam' (Atom n _) = do

72+ putBool False

73+ mat' n

74+jam' (Cell lhs rhs _) = do

75+ putBool True

76+ putBool False

77+ jam' lhs

78+ jam' rhs

9079

9180mat :: Natural -> ByteString

92−mat n = runPut . Put.runBitPut . withBitOrder LL . flip evalStateT (0, M.empty) $ mat' n

81+mat n = runPut . runBitPut . withBitOrder LL $ mat' n

9382

94−mat' :: (BitPrinter m) => Natural -> m ()

95−mat' 0 = putBit# 1##

83+mat' :: Natural -> BitPut ()

84+mat' 0 = putBool True

9685mat' n = do

97− let bitsLength = countBits# n

98− lengthBits = init $ numToBits (W# bitsLength)

99− putBit# 0##

86+ let bits = numToBits n

87+ bitsLength = length bits

88+ lengthBits = init $ numToBits bitsLength

89+ putBool False

10090 putBits $ replicate (length lengthBits) False

101− putBit# 1##

91+ putBool True

10292 putBits lengthBits

103− putNumToBits# n

104−

105−matSize :: Natural -> Word#

106−matSize 0 = 1##

107−matSize n =

108− let bitsLength = countBits# n

109− !(I# lengthBits) = length $ init $ numToBits (W# bitsLength)

110− in 2## `plusWord#` (int2Word# lengthBits `timesWord#` 2##) `plusWord#` bitsLength

93+ putBits bits

11194

112−putBits :: (BitPrinter m) => [Bool] -> m ()

95+putBits :: [Bool] -> BitPut ()

11396putBits [] = pure ()

11497putBits (x : xs) = putBool x >> putBits xs

11598

99+rub :: ByteString -> Natural

100+rub = runGet (runBitGet . withBitOrder LL . flip evalStateT (0, M.empty) $ rub')

101+

102+rub' :: BitParser Natural

103+rub' = do

104+ parseBit >>= \case

105+ True -> pure 0

106+ False -> do

107+ lengthOfLength <- countZeros 0

108+ lengthBits <- (++ [True]) <$> parseBits lengthOfLength

109+ let lent = bitsToNum lengthBits

110+ bitsToNum <$> parseBits lent

111+

112+countZeros :: Int -> BitParser Int

113+countZeros n = do

114+ b <- parseBit

115+ case b of

116+ True -> pure n

117+ False -> countZeros (n + 1)

118+

116119numToBits :: (Bits a, Integral a) => a -> [Bool]

117120numToBits n | n <= 0 = []

118121numToBits n = ((n .&. 1) == 1) : numToBits (shiftR n 1)

119122

120−countBits# :: Natural -> Word#

121−countBits# (NS 0##) = 0##

122−countBits# n = 1## `plusWord#` countBits# (n `naturalShiftR#` 1##)

123−

124−putNumToBits# :: (BitPrinter m) => Natural -> m ()

125−putNumToBits# (NS 0##) = pure ()

126−putNumToBits# n = case n .&. 1 of

127− NS w -> putBit# w >> putNumToBits# (n `naturalShiftR#` 1##)

128− _ -> undefined

123+bitsToNum :: (Bits a, Integral a) => [Bool] -> a

124+bitsToNum = foldr (\b acc -> shiftL acc 1 .|. if b then 1 else 0) 0

src/Nock/Jets.hs+1−14

@@ -1,21 +1,8 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+module Nock.Jets (add, dec) where

22

3−module Nock.Jets (add, dec, decJam, decNoun) where

4−

5−import Data.ByteString (ByteString)

6−import Data.ByteString.Lazy qualified as BSL

7−import Data.FileEmbed (embedFileRelative)

8−import Nock.Cue

9−import Nock.Jam

103import Nock.Parser qualified

114import Nock.Types

125

13−decJam :: ByteString

14−decJam = $(embedFileRelative "res/dec.jam")

15−

16−decNoun :: Noun

17−decNoun = cue $ BSL.fromStrict decJam

18−

196dec :: Noun

207dec = Nock.Parser.noun "[8 [1 0] 8 [1 6 [5 [0 30] 4 0 6] [0 6] 9 2 10 [6 4 0 6] 0 1] 9 2 0 1]"

218

src/Nock/Mug.hsdeleted−34

@@ -1,34 +0,0 @@

1−module Nock.Mug (Mug, mugBS, mugAtom, mugBoth) where

2−

3−import Data.Bits

4−import Data.ByteString (ByteString)

5−import Data.ByteString.Builder

6−import Data.ByteString.Lazy (toStrict)

7−import Data.Hash.Murmur (murmur3)

8−import Data.Word (Word32)

9−import Nock.Types

10−

11−type Mug = Word32

12−

13−mugBS :: ByteString -> Word32

14−mugBS = mum 0xcafe_babe 0x7fff

15−

16−mugAtom :: Atom -> Word32

17−mugAtom = mugBS . atomByteString

18−

19−mugBoth :: Word32 -> Word32 -> Word32

20−mugBoth m n =

21− mum 0xdead_beef 0xfffe $

22− toStrict $

23− toLazyByteString (word32LE m <> word32LE n)

24−

25−mum :: Word32 -> Word32 -> ByteString -> Word32

26−mum syd fal key = go syd 0

27− where

28− go syd 8 = fal

29− go syd i =

30− let haz = murmur3 syd key

31− ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)

32− in if ham /= 0

33− then ham

34− else go (syd + 1) (i + 1)

src/Nock/Types.hs+1−36

@@ -1,9 +1,6 @@

11module Nock.Types

22 ( pretty,

33 Noun (..),

4− Atom,

5− atomShortByteString,

6− atomByteString,

74 Annotation (..),

85 atom,

96 cell,

@@ -14,8 +11,6 @@ module Nock.Types

1411where

1512

1613import Control.DeepSeq

17−import Data.ByteString (ByteString)

18−import Data.ByteString.Short

1914import Data.HashMap.Strict qualified as HM

2015import Data.Text.Lazy qualified as TL

2116import Data.Text.Lazy.Builder qualified as TLB

@@ -24,10 +19,7 @@ import Effectful

2419import Effectful.State.Static.Local qualified as SEL

2520import GHC.Generics

2621import GHC.Natural

27−import GHC.Num (Natural (..))

28−import GHC.Num.BigNat (bigNatFromWord#)

2922import System.Mem.StableName

30−import Test.QuickCheck

3123

3224newtype EqualityCache = EqualityCache (HM.HashMap (StableName Noun, StableName Noun) Bool)

3325 deriving newtype (Semigroup, Monoid)

@@ -69,39 +61,12 @@ annotation :: Noun -> Annotation

6961annotation (Atom _ ann) = ann

7062annotation (Cell _ _ ann) = ann

7163

72−type Atom = Natural

73−

74−atomShortByteString :: Atom -> ShortByteString

75−atomShortByteString (NB ba) = SBS ba

76−atomShortByteString (NS w) = SBS (bigNatFromWord# w)

77−

78−atomByteString :: Atom -> ByteString

79−atomByteString = fromShort . atomShortByteString

80−

8164data Noun

82− = Atom !Atom Annotation

65+ = Atom !Natural Annotation

8366 | Cell !Noun !Noun Annotation

8467 deriving stock (Generic)

8568 deriving anyclass (NFData)

8669

87−instance Eq Noun where

88− (Cell lhsA lhsB _) == (Cell rhsA rhsB _) = lhsA == rhsA && lhsB == rhsB

89− (Atom a _) == (Atom b _) = a == b

90− _ == _ = False

91−

92−instance Ord Noun where

93− Atom {} <= Cell {} = True

94− Cell {} <= Atom {} = False

95− Atom n _ <= Atom m _ = n <= m

96− Cell a b _ <= Cell c d _ = (a, b) <= (c, d)

97−

98−instance Arbitrary Noun where

99− arbitrary =

100− oneof

101− [ atom <$> arbitrarySizedNatural,

102− cell <$> arbitrary <*> arbitrary

103− ]

104−

10570instance Show Noun where

10671 show = TL.unpack . pretty

10772

stack.yaml+2−2

@@ -23,7 +23,7 @@ nix:

2323#

2424# resolver: ./custom-snapshot.yaml

2525# resolver: https://example.com/snapshots/2018-01-01.yaml

26−resolver: lts-23.21

26+resolver: lts-22.43

2727

2828# User packages to be built.

2929# Various formats can be used as shown in the example below.

@@ -51,7 +51,7 @@ extra-deps:

5151# - git: https://github.com/hsyl20/binary-bits.git

5252# commit: 8aa66ff52166ff283b66c7c322108fcb4aa55192

5353- git: https://github.com/ilyakooo0/binary-bits

54− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

54+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

5555# Override default flag values for local packages and extra-deps

5656# flags: {}

5757

stack.yaml.lock+8−8

@@ -5,19 +5,19 @@

55

66packages:

77- completed:

8− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

8+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

99 git: https://github.com/ilyakooo0/binary-bits

1010 name: binary-bits

1111 pantry-tree:

12− sha256: b6f354e26ca7563ad73a3234cd43918ba8edfb5bee7c5e5f8a9173c9109bba66

13− size: 907

12+ sha256: d4886449b9be758d88537eb50a5f9e7c456398c4e1a0b38eb6a2eba07ce71300

13+ size: 808

1414 version: '0.6'

1515 original:

16− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

16+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

1717 git: https://github.com/ilyakooo0/binary-bits

1818snapshots:

1919- completed:

20− sha256: f4a61482dcad21151331bf84ec85bee9be43965f143791fa4bb202ac1e443e1b

21− size: 683833

22− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/21.yaml

23− original: lts-23.21

20+ sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146

21+ size: 720271

22+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml

23+ original: lts-22.43

tests/Main.hs+5−15

@@ -4,36 +4,26 @@ import Control.Monad

44import Data.ByteString.Lazy qualified as BSL

55import Data.Function

66import Data.Text.Lazy.Encoding as TL

7−import Effectful

8−import Effectful.State.Static.Local qualified as SEL

97import Nock

10−import Nock.Cue

11−import Nock.Jam

12−import Nock.Jets

138import Nock.Parser qualified

9+import Nock.Printer

1410import Nock.Types

1511import System.FilePath.Posix

1612import System.Process.Typed

1713import Test.Tasty

1814import Test.Tasty.Golden

19−import Test.Tasty.HUnit (testCase, (@?=))

20−import Test.Tasty.QuickCheck

15+import Effectful

16+import Effectful.State.Static.Local qualified as SEL

2117

2218main :: IO ()

2319main = do

2420 spec <- goldenTest

25− defaultMain $

26− testGroup

27− "nock"

28− [ spec,

29− testProperty "cue . jam == id" (\noun -> noun === (cue . jam) noun),

30− testCase "" (decJam @?= BSL.toStrict ((jam . cue) (BSL.fromStrict decJam)))

31− ]

21+ defaultMain $ spec

3222

3323goldenTest :: IO TestTree

3424goldenTest = do

3525 files <- findByExtension [".hoon"] "tests/golden"

36− fmap (testGroup "golden") $ forM files $ \source -> do

26+ fmap (testGroup "nock") $ forM files $ \source -> do

3727 let target = replaceExtension source ".nock"

3828 pure $ goldenVsString (takeBaseName source) target $ do

3929 hoon <- BSL.readFile source