diff --git a/pkg/proto/lib/Nock.hs b/pkg/proto/lib/Nock.hs index c648727be7..a82e8ae103 100644 --- a/pkg/proto/lib/Nock.hs +++ b/pkg/proto/lib/Nock.hs @@ -34,20 +34,21 @@ no = A 1 -- | Tree address type Axis = Atom -data Nock = NC Nock Nock -- ^ ^: autocons - | N0 Axis -- ^ 0, axis: tree addressing - | N1 Noun -- ^ 1, const: constant - | N2 Nock Nock -- ^ 2, compose: compute subject, formula; apply - | N3 Nock -- ^ 3, is cell - | N4 Nock -- ^ 4, succ - | N5 Nock Nock -- ^ 5, eq - | N6 Nock Nock Nock -- ^ 6, if - | N7 Nock Nock -- ^ 7, then: => - | N8 Nock Nock -- ^ 8, push: =+ - | N9 Axis Nock -- ^ 9, invoke - | N10 (Axis, Nock) Nock -- ^ 10, edit - | N11 Hint Nock -- ^ 11, hint - | N12 Nock Nock -- ^ 12, scry +data Nock + = NC Nock Nock -- ^ ^: autocons + | N0 Axis -- ^ 0, axis: tree addressing + | N1 Noun -- ^ 1, const + | N2 Nock Nock -- ^ 2, compose: compute subject, formula; apply + | N3 Nock -- ^ 3, is cell + | N4 Nock -- ^ 4, succ + | N5 Nock Nock -- ^ 5, eq + | N6 Nock Nock Nock -- ^ 6, if + | N7 Nock Nock -- ^ 7, then: => + | N8 Nock Nock -- ^ 8, push: =+ + | N9 Axis Nock -- ^ 9, invoke + | N10 (Axis, Nock) Nock -- ^ 10, edit + | N11 Hint Nock -- ^ 11, hint + | N12 Nock Nock -- ^ 12, scry deriving (Eq, Ord, Read) data Hint = Tag Atom @@ -121,7 +122,7 @@ nock n = \case N7 f g -> nock (nock n f) g N8 f g -> nock (C (nock n f) n) g N9 a f -> let c = nock n f in nock c (nounToNock (axis a c)) - N10{} -> error "nock: I don't want to implement editing right now" + N10 (a, f) g -> edit a (nock n f) (nock n g) N11 _ f -> nock n f N12{} -> error "nock: scrying is not allowed" @@ -132,9 +133,7 @@ data Dir = L | R deriving (Eq, Ord, Enum, Read, Show) type Path = [Dir] --- Write an axis as a binary number; e.g. 5 as 101. --- The rule is: after droping the 1 in the msb, you read from left to right. --- 0 becomes L and 1 becomes R. +-- some stuff from hoon.hoon cap :: Axis -> Dir cap = \case @@ -171,8 +170,18 @@ axis 1 n = n axis (capMas -> (d, r)) (C n m) = case d of L -> axis r n R -> axis r m -axis a n = error ("bad axis: " ++ show a) +axis a _ = error ("bad axis: " ++ show a) +edit :: Axis -> Tree a -> Tree a -> Tree a +edit 1 v n = v +edit (capMas -> (d, r)) v (C n m) = case d of + L -> C (edit r v n) m + R -> C n (edit r v m) +edit a _ _ = error ("bad edit: " ++ show a) + +-- Write an axis as a binary number; e.g. 5 as 101. +-- The rule is: after droping the 1 in the msb, you read from left to right. +-- 0 becomes L and 1 becomes R. So 5 becomes [L,R] toPath :: Axis -> Path toPath = \case 1 -> [] diff --git a/pkg/proto/lib/UntypedLambda.hs b/pkg/proto/lib/UntypedLambda.hs index ecd418c553..be236605e0 100644 --- a/pkg/proto/lib/UntypedLambda.hs +++ b/pkg/proto/lib/UntypedLambda.hs @@ -105,21 +105,19 @@ data CopyExp | CApp CopyExp CopyExp | CLam [CopyVar] CopyExp -toCopy :: forall a. Ord a => Exp a -> CopyExp +toCopy :: Ord a => Exp a -> CopyExp toCopy = fst . go \v -> error "toCopy: free variable" where - go :: (a -> CopyVar) -> Exp a -> (CopyExp, Set a) + go :: Ord a => (a -> CopyVar) -> Exp a -> (CopyExp, Set a) go env = \case Var v -> (CVar (env v), singleton v) App e f -> (CApp ec fc, union eu fu) where (ec, eu) = go env e (fc, fu) = go env f - Lam s -> (CLam (map env u) c, fromList u) + Lam s -> (CLam (map env u) c, setFromList u) where - c :: CopyExp (c, u') = go env' (fromScope s) - env' :: Var () a -> CopyVar env' = \case B () -> Argument F v -> Lexical (fromJust (elemIndex v u)) @@ -128,19 +126,24 @@ toCopy = fst . go \v -> error "toCopy: free variable" B () -> Nothing F v -> Just v +-- Possible improvements: +-- - store the copied values in a tree rather than list +-- - avoid a nock 8 if nothing is copied copyToNock :: CopyExp -> Nock copyToNock = \case - CVar v -> toAxis case v of + CVar v -> N0 $ toAxis case v of Argument -> [R] - Lexical n -> L : repeat n R ++ L + Lexical n -> L : replicate n R ++ [L] CApp e f -> N2 (copyToNock f) (copyToNock e) + CLam vs e -> lam (map (copyToNock . CVar) vs) (nockToNoun (copyToNock e)) + where + lam vfs ef = NC (N1 (A 8)) (NC (NC (N1 (A 1)) vars) (N1 ef)) + where + vars = foldr NC (N1 (A 0)) vfs -- | The proposed new calling convention -new :: Exp a -> Nock -new = go \v -> error "new: free variable" - where - go = undefined - +copy :: Ord a => Exp a -> Nock +copy = copyToNock . toCopy -- x. y. x