master..391abb1 · nock-hs

bench/Main.hsdeleted−27

since splitsnapshots

unifiedsplit

@@ -1,27 +0,0 @@

1−module Main (main) where

2−

3−import Control.Monad

4−import Data.ByteString.Lazy qualified as BSL

5−import Data.Function

6−import Data.Text.Lazy.Encoding as TL

7−import Gauge

8−import Nock

9−import Nock.Parser (noun)

10−import System.FilePath.Posix

11−import System.Process.Typed

12−import Test.Tasty.Golden (findByExtension)

13−import Effectful

14−

15−main :: IO ()

16−main = do

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

18− benchmarks <- forM files $ \hoonFile -> do

19− hoon <- BSL.readFile hoonFile

20− nock <-

21− fmap (Nock.Parser.noun . TL.decodeUtf8 . BSL.dropEnd 6 . BSL.drop 11 . snd)

22− . readProcessStdout

23− $ proc "urbit" ["eval"]

24− & setStdin (byteStringInput hoon)

25− & setStderr nullStream

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

27− defaultMain benchmarks

exe/Main.hs−1

@@ -1,5 +1,4 @@

1module Main (main) where

2

3−main :: IO ()

4main = pure ()

3main = pure ()

5

4

flake.lockdeleted−59

@@ -1,59 +0,0 @@

1−{

2− "nodes": {

3− "flake-utils": {

4− "inputs": {

5− "systems": "systems"

6− },

7− "locked": {

8− "lastModified": 1731533236,

9− "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",

10− "owner": "numtide",

11− "repo": "flake-utils",

12− "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",

13− "type": "github"

14− },

15− "original": {

16− "id": "flake-utils",

17− "type": "indirect"

18− }

19− },

20− "nixpkgs": {

21− "locked": {

22− "lastModified": 1746141548,

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

24− "owner": "NixOS",

25− "repo": "nixpkgs",

26− "rev": "f02fddb8acef29a8b32f10a335d44828d7825b78",

27− "type": "github"

28− },

29− "original": {

30− "id": "nixpkgs",

31− "ref": "nixos-unstable",

32− "type": "indirect"

33− }

34− },

35− "root": {

36− "inputs": {

37− "flake-utils": "flake-utils",

38− "nixpkgs": "nixpkgs"

39− }

40− },

41− "systems": {

42− "locked": {

43− "lastModified": 1681028828,

44− "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",

45− "owner": "nix-systems",

46− "repo": "default",

47− "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",

48− "type": "github"

49− },

50− "original": {

51− "owner": "nix-systems",

52− "repo": "default",

53− "type": "github"

54− }

55− }

56− },

57− "root": "root",

58− "version": 7

59−}

flake.nixdeleted−24

@@ -1,24 +0,0 @@

1−{

2− inputs = {

3− nixpkgs.url = "nixpkgs/nixos-unstable";

4− flake-utils.url = "flake-utils";

5− };

6−

7− outputs = { self, flake-utils, nixpkgs }:

8− let

9− supportedSystems =

10− [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];

11− compilerVersion = "984";

12− in flake-utils.lib.eachSystem supportedSystems (system:

13− let pkgs = import nixpkgs { inherit system; };

14− in {

15− devShells.default = pkgs.mkShell {

16− buildInputs = with pkgs; [

17− haskell.compiler."ghc${compilerVersion}"

18− (pkgs.haskell-language-server.override {

19− supportedGhcVersions = [ compilerVersion ];

20− })

21− ];

22− };

23− });

24−}

package.yaml−26

@@ -13,16 +13,6 @@ dependencies:

13 - transformers

14 - containers

15 - generic-arbitrary

16− - tasty-golden

17− - typed-process

18− - gauge

19− - filepath

20− - deepseq

21− - effectful

22− - unordered-containers

23− - murmur3

24− - file-embed

25− - mtl

26library:

16library:

27 source-dirs: src

17 source-dirs: src

28

18

@@ -31,18 +21,9 @@ executables:

31 main: Main.hs

21 main: Main.hs

32 source-dirs: exe

22 source-dirs: exe

33

23

34−benchmarks:

35− nock-bench:

36− main: bench/Main.hs

37−

38− dependencies:

39− - effectful

40− - tasty

41− - nock

42ghc-options: >

24ghc-options: >

43 -Weverything

25 -Weverything

44 -Wno-unsafe

26 -Wno-unsafe

45− -Wno-implicit-prelude

46 -Wno-missing-safe-haskell-mode

27 -Wno-missing-safe-haskell-mode

47 -Wno-missing-import-lists

28 -Wno-missing-import-lists

48 -Wno-missing-kind-signatures

29 -Wno-missing-kind-signatures

@@ -50,8 +31,6 @@ ghc-options: >

50 -Wno-missed-specialisations

31 -Wno-missed-specialisations

51 -Wno-partial-type-signatures

32 -Wno-partial-type-signatures

52 -threaded

33 -threaded

53− -with-rtsopts=-N

54− -O2

55

34

56language: GHC2021

35language: GHC2021

57

36

@@ -79,8 +58,6 @@ default-extensions:

79- NoFieldSelectors

58- NoFieldSelectors

80- AllowAmbiguousTypes

59- AllowAmbiguousTypes

81- ImpredicativeTypes

60- ImpredicativeTypes

82−- MagicHash

83−- UnboxedTuples

84

61

85tests:

62tests:

86 spec:

63 spec:

@@ -92,6 +69,3 @@ tests:

92 - nock

69 - nock

93 - tasty-hspec

70 - tasty-hspec

94 - hspec

71 - hspec

95− - 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+88−108

@@ -1,15 +1,31 @@

1{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

2

3−module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun) where

3+module Nock (tar, cell, atom, Annotation (..), Noun, RawNoun (..)) where

4

5−import Data.Bits

5+import Data.Hashable

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

6+import GHC.Generics (Generic)

7−import Effectful

7+import Numeric.Natural

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

8+import Test.QuickCheck.Arbitrary.Generic

9−import GHC.Base

9+

10−import GHC.Num

10+data Annotation = Annotation

11−import GHC.Num.BigNat (bigNatAddWord#, bigNatFromWord2#)

11+ { hash :: Int

12−import Nock.Types

12+ }

13+ deriving stock (Show)

14+

15+zero :: Natural

16+zero = 0

17+

18+atom :: Natural -> Noun

19+atom nat = Atom nat Annotation {hash = hash nat}

20+

21+cell :: Noun -> Noun -> Noun

22+cell lhs rhs =

23+ Cell

24+ lhs

25+ rhs

26+ Annotation

27+ { hash = hash ((annotation lhs).hash, (annotation rhs).hash)

28+ }

13

29

14sig :: Noun

30sig :: Noun

15sig = atom 0

31sig = atom 0

@@ -17,119 +33,83 @@ sig = atom 0

17one :: Noun

33one :: Noun

18one = atom 1

34one = atom 1

19

35

20−two :: Noun

36+annotation :: RawNoun ann -> ann

21−two = atom 2

37+annotation (Atom _ ann) = ann

38+annotation (Cell _ _ ann) = ann

22

39

23−three :: Noun

40+data RawNoun ann

24−three = atom 3

41+ = Atom !Natural ann

42+ | Cell (RawNoun ann) (RawNoun ann) ann

43+ deriving stock (Generic, Show)

25

44

26−four :: Noun

45+instance Eq (RawNoun ann) where

27−four = atom 4

46+ (Atom lhs _) == (Atom rhs _) = lhs == rhs

47+ (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) = lhslhs == rhslhs && lhsrhs == rhsrhs

48+ _ == _ = False

28

49

29−twoThree :: Noun

50+hashEq :: Noun -> Noun -> Bool

30−twoThree = cell two three

51+hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =

52+ lhsAnn.hash == rhsAnn.hash && lhsNat == rhsNat

53+hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =

54+ lhsAnn.hash == rhsAnn.hash && hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs

55+hashEq _ _ = False

31

56

32−sigOne :: Noun

57+type Noun = RawNoun Annotation

33−sigOne = cell sig one

34

58

35wut :: Noun -> Noun

59wut :: Noun -> Noun

36wut Cell {} = sig

60wut Cell {} = sig

37wut Atom {} = one

61wut Atom {} = one

38

62

39lus :: Noun -> Noun

63lus :: Noun -> Noun

40−lus ~(Atom nat _) = atom $ case nat of

64+lus ~(Atom nat _) = atom (nat + 1)

41− (NS n) -> case addWordC# n 1## of

42− (# l, 0# #) -> NS l

43− (# l, c #) -> NB (bigNatFromWord2# (int2Word# c) l)

44− (NB n) -> NB (bigNatAddWord# n 1##)

45

65

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

66+tis :: Noun -> Noun

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

67+tis ~(Cell lhs rhs _) = if hashEq lhs rhs then sig else one

48

68

49−fas# :: Word# -> Noun -> Noun

69+fas :: Noun -> Noun

50−fas# lhs rhs =

70+fas ~(Cell ~(Atom lhs _) rhs _) =

51 case lhs of

71 case lhs of

52− 1## -> rhs

72+ 1 -> rhs

53− 2## -> case rhs of

73+ 2 -> case rhs of

54 ~(Cell lhs' _ _) -> lhs'

74 ~(Cell lhs' _ _) -> lhs'

55− 3## -> case rhs of

75+ 3 -> case rhs of

56 ~(Cell _ rhs' _) -> rhs'

76 ~(Cell _ rhs' _) -> rhs'

57− n ->

77+ n

58− let rest = fas# (uncheckedShiftRL# n 1#) rhs

78+ | n > 0 ->

59− in case and# 1## n of

79+ let (d, m) = divMod n 2

60− 1## -> fas# 3## rest

61− _ -> fas# 2## rest

62−

63−fas :: Natural -> Noun -> Noun

64−fas (NS w) rhs = fas# w rhs

65−fas n rhs =

66− let rest = fas (unsafeShiftR n 1) rhs

67− in if testBit n 0

68− then fas 3 rest

69− else fas 2 rest

70−

71−hax# :: Word# -> Noun -> Noun -> Noun

72−hax# 1## b _ = b

73−hax# n b c =

74− let a = uncheckedShiftRL# n 1#

75− in case and# n 1## of

76− 1## -> hax# a (cell (fas# (n `xor#` 1##) c) b) c

77− _ -> hax# a (cell b (fas# (n `or#` 1##) c)) c

78−

79−hax :: Natural -> Noun -> Noun -> Noun

80−hax (NS n) b c = hax# n b c

81−hax n b c =

82− let a = unsafeShiftR n 1

83− in if testBit n 0

80+ in if m == 0

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

81+ then fas (cell (atom 2) (fas (cell (atom d) rhs)))

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

82+ else fas (cell (atom 3) (fas (cell (atom d) rhs)))

86−

87−tar :: Noun -> Eff es Noun

88−tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject

89−

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

91−tar' b c subject = case b of

92− Cell x y _ -> case c of

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

94− Atom (NB _) _ -> undefined

83+ _ -> undefined

84+

85+hax :: Noun -> Noun

86+hax ~(Cell ~(Atom n _) ~(Cell a b _) _) =

87+ let (d, m) = divMod n 2

95− Atom (NS n) _ -> case n of

88+ in case n of

96− 0## -> case c of

89+ 1 -> a

97− ~(Atom nat _) -> pure $ fas nat subject

90+ _ | m == 0 -> hax (cell (atom d) (cell (cell a (fas (cell (atom $ n + 1) b))) b))

98− 1## -> pure c

91+ _ -> hax (cell (atom d) (cell (cell (fas (cell (atom $ n + n) b)) a) b))

99− 3## -> case c of

92+

100− ~(Cell l k _) -> wut <$> tar' l k subject

93+tar :: Noun -> Noun

101− 4## -> case c of

94+tar ~(Cell a ~(Cell b c _) _) = case b of

102− ~(Cell l k _) -> lus <$> tar' l k subject

95+ Cell x y _ -> cell (tar (cell a (cell x y))) (tar (cell a c))

96+ Atom n _ -> case n of

97+ 0 -> fas $ cell c a

98+ 1 -> c

99+ 3 -> wut $ tar $ cell a c

100+ 4 -> lus $ tar $ cell a c

103 _ -> case c of

101 _ -> case c of

104− ~(Cell x ~(Cell h j _) _) -> case n of

102+ ~(Cell x y _) -> case n of

105− 2## -> case x of

103+ 2 -> tar $ cell (tar $ cell a x) (tar $ cell a y)

106− ~(Cell l k _) ->

104+ 5 -> tis $ cell (tar $ cell a x) (tar $ cell a y)

107− tar' l k subject >>= \case

105+ 7 -> tar $ cell (tar $ cell a x) y

108− ~formula@(Cell battery ~(Cell sample _ _) _) ->

106+ 8 -> tar $ cell (cell (tar $ cell a x) a) y

109− -- if traceShowId battery == Nock.Jets.add

107+ 9 -> tar $ cell (tar $ cell a y) $ cell (atom 2) (cell (cell sig one) (cell sig x))

110− -- then error "Found it!"

108+ 6 -> case y of

111− tar' h j subject >>= \case

109+ ~(Cell l k _) -> tar $ cell a $ tar $ cell (cell l k) $ cell sig $ tar $ cell (cell (atom 2) (atom 3)) $ cell sig $ tar $ cell a (cell (atom 4) (cell (atom 4) x))

112− ~(Cell u v _) -> tar' u v formula

113− 5## -> case x of

114− ~(Cell l k _) -> do

115− p <- tar' h j subject

116− q <- tar' l k subject

117− tis p q

118− 7## -> case x of

119− ~(Cell l k _) -> tar' l k subject >>= tar' h j

120− 8## -> case x of

121− ~(Cell l k _) -> do

122− p <- tar' l k subject

123− tar' h j (cell p subject)

124− 9## -> tar' h j subject >>= tar' two (cell sigOne (cell sig x))

125− 6## -> do

126− p <- tar' four (cell four x) subject

127− q <- tar' sig p twoThree

128− tar' sig q (cell h j) >>= \case

129− ~(Cell u v _) -> tar' u v subject

130− 10## -> case x of

110+ 10 -> case x of

131− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' <$> tar' u v subject <*> tar' h j subject

111+ ~(Cell l k _) -> hax $ cell l $ cell (tar (cell a k)) $ tar $ cell a y

132− 11## -> case x of

112+ 11 -> case c of

133− Cell _ ~(Cell u v _) _ -> tar' h j subject

113+ Cell l k _ -> tar $ cell (cell (tar $ cell a l) (tar $ cell a k)) $ cell sig (atom 3)

134− Atom _ _ -> tar' h j subject

114+ Atom l _ -> tar $ cell a y

135 _ -> undefined

115 _ -> undefined

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+99−103

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

1−{-# LANGUAGE NoMonomorphismRestriction #-}

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

2

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

4−

5−import Control.Monad.Identity

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

7import Control.Monad.Trans.Class

3import Control.Monad.Trans.Class

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

4+import Control.Monad.Trans.State

9import Data.Binary.Bits.BitOrder

5import 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)

11import Data.Binary.Put (runPut)

9import Data.Binary.Put (runPut)

12import Data.Bits

10import Data.Bits

13import Data.ByteString.Lazy (ByteString)

11import Data.ByteString.Lazy (ByteString)

14−import Data.Map.Strict (Map)

12+import Data.Map (Map)

15−import Data.Map.Strict qualified as M

13+import Data.Map qualified as M

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

14+import Data.Word

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

18−import GHC.Num

19−import Nock.Types

15+import Nock

20−

16+import Numeric.Natural

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

17+

22−

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

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

19+

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

20+parseBit :: BitParser Bool

25− putBool :: Bool -> m ()

21+parseBit = do

26−

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

28− putBit# _ = do

29− (counter, m) <- get

22+ (counter, m) <- get

30− put (counter + 1, m)

23+ b <- lift getBool

31− putBool _ = do

32− (counter, m) <- get

33− put (counter + 1, m)

24+ put (counter + 1, m)

34−

25+ pure b

35−instance BitPrinter BitPrinterM where

26+

36− putBit# w = do

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

37− (counter, m) <- get

28+parseBits 0 = pure []

38− lift $ Put.putBool# w

29+parseBits n = do

39− put (counter + 1, m)

30+ b <- parseBit

40− putBool b = do

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

41− (counter, m) <- get

32+

42− lift $ Put.putBool b

33+getOffset :: BitParser Int

43− put (counter + 1, m)

44−

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

46getOffset = fst <$> get

34getOffset = fst <$> get

47

35

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

36+cue :: ByteString -> Noun

49−getMapping = snd <$> get

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

50

38

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

39+cue' :: BitParser Noun

52−putMapping idx n = do

40+cue' = do

41+ offset <- getOffset

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

53− (offset, m) <- get

57+ (offset, m) <- get

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

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

55

66

56jam :: Noun -> ByteString

67jam :: Noun -> ByteString

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

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

58−

69+

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

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

60−jam' n = do

61− 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

71+jam' (Atom n _) = do

68− putBit# 0##

72+ putBool False

69− mat' a

73+ mat' n

70− (Cell lhs rhs _) -> do

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

71− putBit# 1##

75+ putBool True

72− putBit# 0##

76+ putBool False

73− jam' lhs

77+ jam' lhs

74− jam' rhs

78+ 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

90

79

91mat :: Natural -> ByteString

80mat :: 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

93

82

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

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

95−mat' 0 = putBit# 1##

84+mat' 0 = putBool True

96mat' n = do

85mat' n = do

97− let bitsLength = countBits# n

86+ let bits = numToBits n

87+ bitsLength = length bits

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

88+ lengthBits = init $ numToBits bitsLength

99− putBit# 0##

89+ putBool False

100 putBits $ replicate (length lengthBits) False

90 putBits $ replicate (length lengthBits) False

101− putBit# 1##

91+ putBool True

102 putBits lengthBits

92 putBits lengthBits

103− putNumToBits# n

93+ putBits bits

104

94

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

111−

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

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

113putBits [] = pure ()

96putBits [] = pure ()

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

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

115

98

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+

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

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

117numToBits n | n <= 0 = []

120numToBits n | n <= 0 = []

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

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

119

122

120−countBits# :: Natural -> Word#

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

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

124+bitsToNum = foldr (\b acc -> shiftL acc 1 .|. if b then 1 else 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

src/Nock/Jets.hsdeleted−23

@@ -1,23 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−

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

10−import Nock.Parser qualified

11−import Nock.Types

12−

13−decJam :: ByteString

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

15−

16−decNoun :: Noun

17−decNoun = cue $ BSL.fromStrict decJam

18−

19−dec :: Noun

20−dec = 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]"

21−

22−add :: Noun

23−add = Nock.Parser.noun "[ 6 [5 [1 0] 0 12] [0 13] 9 2 10 [6 [8 [9 21 0 7] 9 2 10 [6 0 28] 0 2] 4 0 13] 0 1 ]"

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/Parser.hs+11−13

@@ -1,21 +1,20 @@

1{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

2

3−module Nock.Parser (noun) where

3+module Nock.Parser (decode) where

4

5−import Control.Applicative

6−import Data.Text.Lazy as TL

5+import Data.Text as T

7import Data.Void (Void)

6import Data.Void (Void)

8−import Nock.Types

7+import Nock

9import Text.Megaparsec

8import Text.Megaparsec

10import Text.Megaparsec.Char

9import Text.Megaparsec.Char

11import Text.Megaparsec.Char.Lexer (decimal)

10import Text.Megaparsec.Char.Lexer (decimal)

12

11

13−noun :: TL.Text -> Noun

12+decode :: Text -> Noun

14−noun txt = case Text.Megaparsec.parse (space *> parser <* space) "" . TL.filter (\c -> c /= '.') $ txt of

13+decode txt = case Text.Megaparsec.parse parser "" . T.filter (\c -> c /= '.') $ txt of

15 Right non -> non

14 Right non -> non

16 Left err -> error $ errorBundlePretty err

15 Left err -> error $ errorBundlePretty err

17

16

18−type Parser = Parsec Void TL.Text

17+type Parser = Parsec Void Text

19

18

20parser :: Parser Noun

19parser :: Parser Noun

21parser = try atomParser <|> cellParser

20parser = try atomParser <|> cellParser

@@ -27,13 +26,12 @@ cellParser :: Parser Noun

27cellParser = do

26cellParser = do

28 char '['

27 char '['

29 space

28 space

30− nons <- sugarCell

29+ h <- parser

30+ space1

31+ t <- sepBy parser space1

32+ space

31 char ']'

33 char ']'

32− pure $ toCell nons

34+ pure $ toCell (h : t)

33−

34−sugarCell :: Parser [Noun]

35−sugarCell = do

36− try (liftA2 (:) (try (parser <* space)) sugarCell) <|> pure []

37

35

38toCell :: [Noun] -> Noun

36toCell :: [Noun] -> Noun

39toCell = \case

37toCell = \case

src/Nock/Printer.hsdeleted−6

@@ -1,6 +0,0 @@

1−module Nock.Printer () where

2−

3−import Data.Text.Lazy qualified as TL

4−import Data.Text.Lazy.Builder qualified as TLB

5−import Data.Text.Lazy.Builder.Int qualified as TLB

6−import Nock

src/Nock/Types.hsdeleted−114

@@ -1,114 +0,0 @@

1−module Nock.Types

2− ( pretty,

3− Noun (..),

4− Atom,

5− atomShortByteString,

6− atomByteString,

7− Annotation (..),

8− atom,

9− cell,

10− nounEq,

11− EqualityCache,

12− annotation,

13− )

14−where

15−

16−import Control.DeepSeq

17−import Data.ByteString (ByteString)

18−import Data.ByteString.Short

19−import Data.HashMap.Strict qualified as HM

20−import Data.Text.Lazy qualified as TL

21−import Data.Text.Lazy.Builder qualified as TLB

22−import Data.Text.Lazy.Builder.Int qualified as TLB

23−import Effectful

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

25−import GHC.Generics

26−import GHC.Natural

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

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

29−import System.Mem.StableName

30−import Test.QuickCheck

31−

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

33− deriving newtype (Semigroup, Monoid)

34−

35−nounEq :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Noun -> Eff es Bool

36−nounEq x y = do

37− xName <- liftIO $ makeStableName x

38− yName <- liftIO $ makeStableName y

39− EqualityCache cache <- SEL.get

40− case HM.lookup (xName, yName) cache of

41− Just res -> pure res

42− Nothing -> do

43− res <- case (x, y) of

44− (Atom xa _, Atom ya _) -> pure $ xa == ya

45− (Cell xLhs xRhs _, Cell yLhs yRhs _) -> do

46− lhsRes <- nounEq xLhs yLhs

47− if lhsRes then nounEq xRhs yRhs else pure False

48− _ -> pure False

49− SEL.put $ EqualityCache $ HM.insert (xName, yName) res $ HM.insert (yName, xName) res $ cache

50− pure res

51−

52−data Annotation = Annotation

53− deriving stock (Show, Generic)

54− deriving anyclass (NFData)

55−

56−atom :: Natural -> Noun

57−atom nat = Atom nat Annotation {}

58−

59−cell :: Noun -> Noun -> Noun

60−cell lhs rhs =

61− Cell

62− lhs

63− rhs

64− Annotation

65− {

66− }

67−

68−annotation :: Noun -> Annotation

69−annotation (Atom _ ann) = ann

70−annotation (Cell _ _ ann) = ann

71−

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−

81−data Noun

82− = Atom !Atom Annotation

83− | Cell !Noun !Noun Annotation

84− deriving stock (Generic)

85− deriving anyclass (NFData)

86−

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−

105−instance Show Noun where

106− show = TL.unpack . pretty

107−

108−pretty :: Noun -> TL.Text

109−pretty noun = TLB.toLazyText $ pretty' noun False

110−

111−pretty' :: Noun -> Bool -> TLB.Builder

112−pretty' (Atom a _) _ = TLB.decimal a

113−pretty' (Cell lhs rhs _) True = pretty' lhs False <> " " <> pretty' rhs True

114−pretty' (Cell lhs rhs _) False = "[" <> pretty' lhs False <> " " <> pretty' rhs True <> "]"

stack.yaml+3−3

@@ -3,7 +3,6 @@ nix:

3 packages:

4 - zlib

5 - pkg-config

6− - urbit

7# This file was automatically generated by 'stack init'

6# This file was automatically generated by 'stack init'

8#

7#

9# Some commonly used options have been documented as comments in this file.

8# Some commonly used options have been documented as comments in this file.

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

23#

22#

24# resolver: ./custom-snapshot.yaml

23# resolver: ./custom-snapshot.yaml

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

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

26−resolver: lts-23.21

25+resolver:

26+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml

27

28# User packages to be built.

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

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

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

52# commit: 8aa66ff52166ff283b66c7c322108fcb4aa55192

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

54− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

54+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

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

56# flags: {}

57

stack.yaml.lock+9−8

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

5

6packages:

7- completed:

8− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

8+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

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

10 name: binary-bits

11 pantry-tree:

12− sha256: b6f354e26ca7563ad73a3234cd43918ba8edfb5bee7c5e5f8a9173c9109bba66

12+ sha256: d4886449b9be758d88537eb50a5f9e7c456398c4e1a0b38eb6a2eba07ce71300

13− size: 907

13+ size: 808

14 version: '0.6'

15 original:

16− commit: 21adca7da6e378c8e3cc7bb1afa9dd441a721016

16+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03

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

18snapshots:

19- completed:

20− sha256: f4a61482dcad21151331bf84ec85bee9be43965f143791fa4bb202ac1e443e1b

20+ sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6

21− size: 683833

21+ size: 640239

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

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

23− original: lts-23.21

23+ original:

24+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml

tests/Main.hs+35−38

@@ -1,48 +1,45 @@

1module Main (main) where

2

3−import Control.Monad

4import Data.ByteString.Lazy qualified as BSL

3import Data.ByteString.Lazy qualified as BSL

5−import Data.Function

4+import Data.Text as T

6−import Data.Text.Lazy.Encoding as TL

5+import Debug.Trace

7−import Effectful

6+import Debug.Trace (traceShowId)

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

9import Nock

7import Nock

10−import Nock.Cue

11import Nock.Jam

8import Nock.Jam

12−import Nock.Jets

9+import Nock.Parser

13−import Nock.Parser qualified

14−import Nock.Types

10+import Test.Hspec

15−import System.FilePath.Posix

11+import Test.Hspec.QuickCheck

16−import System.Process.Typed

12+import Test.QuickCheck

17import Test.Tasty

13import Test.Tasty

18−import Test.Tasty.Golden

14+import Test.Tasty.Hspec

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

20−import Test.Tasty.QuickCheck

21

15

22main :: IO ()

16main :: IO ()

23main = do

17main = do

24− spec <- goldenTest

18+ spec <- testSpec "nock" specs

25− defaultMain $

19+ defaultMain spec

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− ]

32

20

33−goldenTest :: IO TestTree

21+specs :: Spec

34−goldenTest = do

22+specs = describe "nock" $ do

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

23+ tarTest "[[[4 5] [6 14 15]] [0 7]]" "[14 15]"

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

24+ tarTest "[77 [2 [1 42] [1 1 153 218]]]" "[153 218]"

37− let target = replaceExtension source ".nock"

25+ tarTest "[[132 19] [4 0 3]]" "20"

38− pure $ goldenVsString (takeBaseName source) target $ do

26+

39− hoon <- BSL.readFile source

27+ prop

40− nock <-

28+ "rub (mat atom) = atom"

41− fmap (Nock.Parser.noun . TL.decodeUtf8 . BSL.dropEnd 6 . BSL.drop 11 . snd)

29+ ( \(NonNegative (a :: Integer)) (NonNegative (b :: Integer)) (NonNegative (c :: Integer)) ->

42− . readProcessStdout

30+ withMaxSuccess 10000 $

43− $ proc "urbit" ["eval"]

31+ let atom = fromInteger (a * b * c * 11)

44− & setStdin (byteStringInput hoon)

32+ in rub (mat atom) === atom

45− & setStderr nullStream

33+ )

46− noun <- runEff . SEL.evalState (mempty :: EqualityCache) . tar $ cell (atom 0) nock

34+ describe "cue (jam noun) = noun" $ do

47− let result = TL.encodeUtf8 . pretty $ noun

35+ testJam "[77 [2 [1 42] [1 1 153 218]]]"

48− pure result

36+

37+tarTest :: Text -> Text -> Spec

38+tarTest source target =

39+ it (T.unpack ("*" <> source <> " = " <> target)) $

40+ tar (decode source) == decode target

41+

42+testJam :: Text -> Spec

43+testJam source =

44+ it ("cue (jam " ++ T.unpack source ++ ") = source") $

45+ cue (jam (decode source)) == decode source

tests/golden/add.hoondeleted−24

@@ -1,24 +0,0 @@

1−!=

2−=>

3−|%

4−++ foo 1

5−++ baz |= x=@ x

6−++ dec

7−|= a=@

8−=/ b 0

9−|- ^- @

10−?. =(a +(b)) $(b +(b)) b

11−++ bar 2

12−++ add

13− :: ~/ %add

14− :: unsigned addition

15− ::

16− :: a: augend

17− :: b: addend

18− |= [a=@ b=@]

19− :: sum

20− ^- @

21− ?: =(0 a) b

22− $(a (dec a), b +(b))

23−--

24−(add 3 5)

tests/golden/add.nockdeleted−1

@@ -1 +0,0 @@

1−8

tests/golden/dec.hoondeleted−16

@@ -1,16 +0,0 @@

1−!=

2−=>

3−|%

4−++ add

5− |= x=@

6− x

7−++ bar 4

8−++ dec

9−|= a=@

10−=/ b 0

11−|- ^- @

12−?. =(a +(b)) $(b +(b)) b

13−--

14−%-

15−dec

16−5

tests/golden/dec.nockdeleted−1

@@ -1 +0,0 @@

1−4

tests/golden/mul.hoondeleted−37

@@ -1,37 +0,0 @@

1−!=

2−=>

3−|%

4−++ mul

5− ~/ %mul

6− :: unsigned multiplication

7− ::

8− :: a: multiplicand

9− :: b: multiplier

10− |: [a=`@`1 b=`@`1]

11− :: product

12− ^- @

13− =+ c=0

14− |-

15− ?: =(0 a) c

16− $(a (dec a), c (add b c))

17−++ foo 1

18−++ baz |= x=@ x

19−++ dec

20−|= a=@

21−=/ b 0

22−|- ^- @

23−?. =(a +(b)) $(b +(b)) b

24−++ bar 2

25−++ add

26− :: ~/ %add

27− :: unsigned addition

28− ::

29− :: a: augend

30− :: b: addend

31− |= [a=@ b=@]

32− :: sum

33− ^- @

34− ?: =(0 a) b

35− $(a (dec a), b +(b))

36−--

37−(mul 3 5)

tests/golden/mul.nockdeleted−1

@@ -1 +0,0 @@

1−15