be02e58 · nock-hs · git.iko.soy

src/Nock.hs+12−62

compare with master

unifiedsplit

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

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

2

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

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

4

5import Control.DeepSeq (NFData, force)

6import Data.Bits

@@ -13,24 +13,8 @@ import GHC.Base

13import GHC.Conc (par)

14import GHC.Generics (Generic)

15import GHC.Num

16−

16+import Nock.Jets

17−newtype Annotation = Annotation

17+import Nock.Types

18− { hash :: Int

19− }

20− deriving stock (Show, Generic)

21− deriving anyclass (NFData)

22−

23−atom :: Natural -> Noun

24−atom nat = Atom nat Annotation {hash = hash nat}

25−

26−cell :: Noun -> Noun -> Noun

27−cell lhs rhs =

28− Cell

29− lhs

30− rhs

31− Annotation

32− { hash = hash ((annotation lhs).hash, (annotation rhs).hash)

33− }

34

18

35sig :: Noun

19sig :: Noun

36sig = atom 0

20sig = atom 0

@@ -53,37 +37,6 @@ twoThree = cell two three

53sigOne :: Noun

37sigOne :: Noun

54sigOne = cell sig one

38sigOne = cell sig one

55

39

56−annotation :: RawNoun ann -> ann

57−annotation (Atom _ ann) = ann

58−annotation (Cell _ _ ann) = ann

59−

60−data RawNoun ann

61− = Atom !Natural ann

62− | Cell (RawNoun ann) (RawNoun ann) ann

63− deriving stock (Generic)

64− deriving anyclass (NFData)

65−

66−instance Show (RawNoun ann) where

67− show = TL.unpack . pretty

68−

69−instance Eq (RawNoun ann) where

70− (Atom lhs _) == (Atom rhs _) = lhs == rhs

71− (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) =

72− let rhsRes = lhsrhs == rhsrhs

73− in (force rhsRes `par` lhslhs == rhslhs) && rhsRes

74− _ == _ = False

75−

76−hashEq :: Noun -> Noun -> Bool

77−hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =

78− let normalEq = lhsNat == rhsNat

79− in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq

80−hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =

81− let normalEq = hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs

82− in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq

83−hashEq _ _ = False

84−

85−type Noun = RawNoun Annotation

86−

87wut :: Noun -> Noun

40wut :: Noun -> Noun

88wut Cell {} = sig

41wut Cell {} = sig

89wut Atom {} = one

42wut Atom {} = one

@@ -149,9 +102,14 @@ tar' b c subject = case b of

149 4## -> case c of

102 4## -> case c of

150 ~(Cell l k _) -> lus $ tar' l k subject

103 ~(Cell l k _) -> lus $ tar' l k subject

151 _ -> case c of

104 _ -> case c of

152− ~(Cell x ~formula@(Cell h j _) _) -> case n of

105+ ~(Cell x ~(Cell h j _) _) -> case n of

153− 2## -> case (tar' h j subject, x) of

106+ 2## -> case x of

154− ~(~(Cell u v _), ~(Cell l k _)) -> tar' u v (tar' l k subject)

107+ ~(Cell l k _) -> case tar' l k subject of

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

109+ if battery == Nock.Jets.dec

110+ then error "Found it!"

111+ else case (tar' h j subject) of

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

155 5## -> case x of

113 5## -> case x of

156 ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)

114 ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)

157 7## -> case x of

115 7## -> case x of

@@ -164,14 +122,6 @@ tar' b c subject = case b of

164 10## -> case x of

122 10## -> case x of

165 ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)

123 ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)

166 11## -> case x of

124 11## -> case x of

167− Cell _ ~(Cell u v _) _ -> traceShow (formula, subject) $ tar' h j subject

125+ Cell _ ~(Cell u v _) _ -> tar' h j subject

168 Atom _ _ -> tar' h j subject

126 Atom _ _ -> tar' h j subject

169 _ -> undefined

127 _ -> undefined

170−

171−pretty :: RawNoun ann -> TL.Text

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

173−

174−pretty' :: RawNoun ann -> Bool -> TLB.Builder

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

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

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

src/Nock/Jets.hsnew file+10

@@ -0,0 +1,10 @@

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

2+

3+import Nock.Parser qualified

4+import Nock.Types

5+

6+dec :: Noun

7+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]"

8+

9+add :: Noun

10+add = Nock.Parser.noun "[ [ 6 [5 [1 0] 0 12] [0 13] 9 2 10 [6 [8 [9 5 0 7] 9 2 10 [6 0 28] 0 2] 4 0 13] 0 1 ] [0 0] [ [ 8 [1 0 0] [ 1 6 [5 [1 0] 0 12] [0 13] 9 2 10 [6 [8 [9 5 0 7] 9 2 10 [6 0 28] 0 2] 4 0 13] 0 1 ] 0 1 ] 7 [ 8 [1 69] [ 1 6 [5 [1 0] 0 6] [0 0] 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 ] 0 1 ] 11 [1.953.718.630 1 6.514.020 [0 7] 0] 0 1 ] 0 ]"

src/Nock/Parser.hs+1−1

@@ -5,7 +5,7 @@ module Nock.Parser (noun) where

5import Control.Applicative

6import Data.Text.Lazy as TL

7import Data.Void (Void)

8−import Nock

8+import Nock.Types

9import Text.Megaparsec

10import Text.Megaparsec.Char

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

src/Nock/Types.hsnew file+67

@@ -0,0 +1,67 @@

1+module Nock.Types (pretty, hashEq, Noun, RawNoun (..), Annotation (..), atom, cell) where

2+

3+import Control.DeepSeq

4+import Data.Hashable

5+import Data.Text.Lazy qualified as TL

6+import Data.Text.Lazy.Builder qualified as TLB

7+import Data.Text.Lazy.Builder.Int qualified as TLB

8+import GHC.Conc

9+import GHC.Generics

10+import GHC.Natural

11+

12+newtype Annotation = Annotation

13+ { hash :: Int

14+ }

15+ deriving stock (Show, Generic)

16+ deriving anyclass (NFData)

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

29+

30+annotation :: RawNoun ann -> ann

31+annotation (Atom _ ann) = ann

32+annotation (Cell _ _ ann) = ann

33+

34+data RawNoun ann

35+ = Atom !Natural ann

36+ | Cell !(RawNoun ann) !(RawNoun ann) ann

37+ deriving stock (Generic)

38+ deriving anyclass (NFData)

39+

40+instance Show (RawNoun ann) where

41+ show = TL.unpack . pretty

42+

43+instance Eq (RawNoun ann) where

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

45+ (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) =

46+ let rhsRes = lhsrhs == rhsrhs

47+ in (force rhsRes `par` lhslhs == rhslhs) && rhsRes

48+ _ == _ = False

49+

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

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

52+ let normalEq = lhsNat == rhsNat

53+ in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq

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

55+ let normalEq = hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs

56+ in (force normalEq `par` lhsAnn.hash == rhsAnn.hash) && normalEq

57+hashEq _ _ = False

58+

59+type Noun = RawNoun Annotation

60+

61+pretty :: RawNoun ann -> TL.Text

62+pretty noun = TLB.toLazyText $ pretty' noun False

63+

64+pretty' :: RawNoun ann -> Bool -> TLB.Builder

65+pretty' (Atom a _) _ = TLB.decimal a

66+pretty' (Cell lhs rhs _) True = pretty' lhs False <> " " <> pretty' rhs True

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

tests/Main.hs+1

@@ -7,6 +7,7 @@ import Data.Text.Lazy.Encoding as TL

7import Nock

8import Nock.Parser qualified

9import Nock.Printer

10+import Nock.Types

10import System.FilePath.Posix

11import System.FilePath.Posix

11import System.Process.Typed

12import System.Process.Typed

12import Test.Tasty

13import Test.Tasty

tests/golden/add-nock.nocknew file

No changes to the content.

tests/golden/add.hoon+8−13

@@ -1,19 +1,15 @@

1!=

2=>

3|%

4+++ foo 1

4++ dec

5++ dec

5− ~/ %dec

6− :: unsigned decrement by one.

7− |= a=@

6+|= a=@

8− ~_ leaf+"decrement-underflow"

9− ?< =(0 a)

10− =+ b=0

7+=/ b 0

11− :: decremented integer

12− |- ^- @

8+|- ^- @

13− ?: =(a +(b)) b

14− $(b +(b))

9+?. =(a +(b)) $(b +(b)) b

10+++ bar 1

15++ add

11++ add

16− ~/ %add

12+ :: ~/ %add

17 :: unsigned addition

13 :: unsigned addition

18 ::

14 ::

19 :: a: augend

15 :: a: augend

@@ -24,5 +20,4 @@

24 ?: =(0 a) b

20 ?: =(0 a) b

25 $(a (dec a), b +(b))

21 $(a (dec a), b +(b))

26--

22--

27−%+ add

23+%+ add 1 2

28−1.000 1.000

tests/golden/dec.hoon+1−3

@@ -6,7 +6,5 @@

6=/ b 0

7|- ^- @

8?. =(a +(b)) $(b +(b)) b

9−

10--

9--

11−

12−%- dec 1.000.000

10+%- dec 8