@@ -1,19 +1,13 @@
11{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
22
3−module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) where
3+module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun) where
44
5−import Control.DeepSeq (NFData, force)
65import Data.Bits
7−import Data.Hashable
8−import Data.Text.Lazy qualified as TL
9−import Data.Text.Lazy.Builder qualified as TLB
10−import Data.Text.Lazy.Builder.Int qualified as TLB
11−import Debug.Trace
6+import Data.Functor ((<&>))
7+import Effectful
8+import Effectful.State.Static.Local qualified as SEL
129import GHC.Base
13−import GHC.Conc (par)
14−import GHC.Generics (Generic)
1510import GHC.Num
16−import Nock.Jets
1711import Nock.Types
1812
1913sig :: Noun
@@ -44,8 +38,8 @@ wut Atom {} = one
4438lus :: Noun -> Noun
4539lus ~(Atom nat _) = atom (nat + 1)
4640
47−tis :: Noun -> Noun -> Noun
48−tis lhs rhs = if hashEq lhs rhs then sig else one
41+tis :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Noun -> Eff es Noun
42+tis lhs rhs = nounEq lhs rhs <&> \eq -> if eq then sig else one
4943
5044fasWord :: Word# -> Noun -> Noun
5145fasWord lhs rhs =
@@ -70,7 +64,6 @@ fas n rhs =
7064 else fas 2 rest
7165
7266haxWord :: Word# -> Noun -> Noun -> Noun
73−haxWord _ _ tree | traceShow tree False = undefined
7467haxWord 1## newValue _ = newValue
7568haxWord place newValue ~(Cell lhs rhs _) =
7669 let a = uncheckedShiftRL# place 1#
@@ -78,48 +71,60 @@ haxWord place newValue ~(Cell lhs rhs _) =
7871 1## -> cell (haxWord a newValue lhs) rhs
7972 _ -> cell lhs (haxWord a newValue rhs)
8073
74+hax :: Natural -> Noun -> Noun -> Noun
75+hax (NS n) b c = haxWord n b c
8176hax n b c =
8277 let a = unsafeShiftR n 1
8378 in case n of
8479 1 -> b
8580 _ | testBit n 0 -> hax a (cell (fas (n - 1) c) b) c
8681 _ -> hax a (cell b (fas (n + 1) c)) c
87−tar :: Noun -> Noun
82+
83+tar :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Eff es Noun
8884tar ~(Cell subject ~(Cell a b _) _) = tar' a b subject
8985
90−tar' :: Noun -> Noun -> Noun -> Noun
86+tar' :: (SEL.State EqualityCache :> es, IOE :> es) => Noun -> Noun -> Noun -> Eff es Noun
9187tar' b c subject = case b of
9288 Cell x y _ -> case c of
93− ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
89+ ~(Cell l k _) -> cell <$> tar' x y subject <*> tar' l k subject
9490 Atom (NB _) _ -> undefined
9591 Atom (NS n) _ -> case n of
9692 0## -> case c of
97− ~(Atom nat _) -> fas nat subject
98− 1## -> c
93+ ~(Atom nat _) -> pure $ fas nat subject
94+ 1## -> pure c
9995 3## -> case c of
100− ~(Cell l k _) -> wut $ tar' l k subject
96+ ~(Cell l k _) -> wut <$> tar' l k subject
10197 4## -> case c of
102− ~(Cell l k _) -> lus $ tar' l k subject
98+ ~(Cell l k _) -> lus <$> tar' l k subject
10399 _ -> case c of
104100 ~(Cell x ~(Cell h j _) _) -> case n of
105101 2## -> case x of
106− ~(Cell l k _) -> case tar' l k subject of
107− ~(formula@(Cell battery ~(Cell sample _ _) _)) ->
108− -- if traceShowId battery == Nock.Jets.add
109− -- then error "Found it!"
110− case (tar' h j subject) of
111− ~(Cell u v _) -> tar' u v formula
102+ ~(Cell l k _) ->
103+ tar' l k subject >>= \case
104+ ~formula@(Cell battery ~(Cell sample _ _) _) ->
105+ -- if traceShowId battery == Nock.Jets.add
106+ -- then error "Found it!"
107+ tar' h j subject >>= \case
108+ ~(Cell u v _) -> tar' u v formula
112109 5## -> case x of
113− ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)
110+ ~(Cell l k _) -> do
111+ p <- tar' h j subject
112+ q <- tar' l k subject
113+ tis p q
114114 7## -> case x of
115− ~(Cell l k _) -> tar' h j (tar' l k subject)
115+ ~(Cell l k _) -> tar' l k subject >>= tar' h j
116116 8## -> case x of
117− ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
118− 9## -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
119− 6## -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
120− ~(Cell u v _) -> tar' u v subject
117+ ~(Cell l k _) -> do
118+ p <- tar' l k subject
119+ tar' h j (cell p subject)
120+ 9## -> tar' h j subject >>= tar' two (cell sigOne (cell sig x))
121+ 6## -> do
122+ p <- tar' four (cell four x) subject
123+ q <- tar' sig p twoThree
124+ tar' sig q (cell h j) >>= \case
125+ ~(Cell u v _) -> tar' u v subject
121126 10## -> case x of
122− ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)
127+ ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' <$> tar' u v subject <*> tar' h j subject
123128 11## -> case x of
124129 Cell _ ~(Cell u v _) _ -> tar' h j subject
125130 Atom _ _ -> tar' h j subject