urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-21 01:41:37 +03:00
Code Issues Packages Projects Releases Wiki Activity

new calling convention ("copy") now works

Browse Source
This commit is contained in:
pilfer-pandex 2019-09-17 14:46:48 -07:00
parent 489ad3f90f
commit b454305f67
2 changed files with 43 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
pkg/proto/lib/Nock.hs
View File

@ -34,20 +34,21 @@ no = A 1
-- | Tree address -- | Tree address
type Axis = Atom type Axis = Atom
data Nock = NC Nock Nock -- ^ ^: autocons data Nock
| N0 Axis -- ^ 0, axis: tree addressing = NC Nock Nock -- ^ ^: autocons
| N1 Noun -- ^ 1, const: constant | N0 Axis -- ^ 0, axis: tree addressing
| N2 Nock Nock -- ^ 2, compose: compute subject, formula; apply | N1 Noun -- ^ 1, const
| N3 Nock -- ^ 3, is cell | N2 Nock Nock -- ^ 2, compose: compute subject, formula; apply
| N4 Nock -- ^ 4, succ | N3 Nock -- ^ 3, is cell
| N5 Nock Nock -- ^ 5, eq | N4 Nock -- ^ 4, succ
| N6 Nock Nock Nock -- ^ 6, if | N5 Nock Nock -- ^ 5, eq
| N7 Nock Nock -- ^ 7, then: => | N6 Nock Nock Nock -- ^ 6, if
| N8 Nock Nock -- ^ 8, push: =+ | N7 Nock Nock -- ^ 7, then: =>
| N9 Axis Nock -- ^ 9, invoke | N8 Nock Nock -- ^ 8, push: =+
| N10 (Axis, Nock) Nock -- ^ 10, edit | N9 Axis Nock -- ^ 9, invoke
| N11 Hint Nock -- ^ 11, hint | N10 (Axis, Nock) Nock -- ^ 10, edit
| N12 Nock Nock -- ^ 12, scry | N11 Hint Nock -- ^ 11, hint
| N12 Nock Nock -- ^ 12, scry
deriving (Eq, Ord, Read) deriving (Eq, Ord, Read)
data Hint = Tag Atom data Hint = Tag Atom
@ -121,7 +122,7 @@ nock n = \case
N7 f g -> nock (nock n f) g N7 f g -> nock (nock n f) g
N8 f g -> nock (C (nock n f) n) 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)) 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 N11 _ f -> nock n f
N12{} -> error "nock: scrying is not allowed" N12{} -> error "nock: scrying is not allowed"
@ -132,9 +133,7 @@ data Dir = L | R
deriving (Eq, Ord, Enum, Read, Show) deriving (Eq, Ord, Enum, Read, Show)
type Path = [Dir] type Path = [Dir]
-- Write an axis as a binary number; e.g. 5 as 101. -- some stuff from hoon.hoon
-- The rule is: after droping the 1 in the msb, you read from left to right.
-- 0 becomes L and 1 becomes R.
cap :: Axis -> Dir cap :: Axis -> Dir
cap = \case cap = \case
@ -171,8 +170,18 @@ axis 1 n = n
axis (capMas -> (d, r)) (C n m) = case d of axis (capMas -> (d, r)) (C n m) = case d of
L -> axis r n L -> axis r n
R -> axis r m 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 :: Axis -> Path
toPath = \case toPath = \case
1 -> [] 1 -> []

27
pkg/proto/lib/UntypedLambda.hs
View File

@ -105,21 +105,19 @@ data CopyExp
| CApp CopyExp CopyExp | CApp CopyExp CopyExp
| CLam [CopyVar] 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" toCopy = fst . go \v -> error "toCopy: free variable"
where where
go :: (a -> CopyVar) -> Exp a -> (CopyExp, Set a) go :: Ord a => (a -> CopyVar) -> Exp a -> (CopyExp, Set a)
go env = \case go env = \case
Var v -> (CVar (env v), singleton v) Var v -> (CVar (env v), singleton v)
App e f -> (CApp ec fc, union eu fu) App e f -> (CApp ec fc, union eu fu)
where where
(ec, eu) = go env e (ec, eu) = go env e
(fc, fu) = go env f (fc, fu) = go env f
Lam s -> (CLam (map env u) c, fromList u) Lam s -> (CLam (map env u) c, setFromList u)
where where
c :: CopyExp
(c, u') = go env' (fromScope s) (c, u') = go env' (fromScope s)
env' :: Var () a -> CopyVar
env' = \case env' = \case
B () -> Argument B () -> Argument
F v -> Lexical (fromJust (elemIndex v u)) F v -> Lexical (fromJust (elemIndex v u))
@ -128,19 +126,24 @@ toCopy = fst . go \v -> error "toCopy: free variable"
B () -> Nothing B () -> Nothing
F v -> Just v 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 :: CopyExp -> Nock
copyToNock = \case copyToNock = \case
CVar v -> toAxis case v of CVar v -> N0 $ toAxis case v of
Argument -> [R] Argument -> [R]
Lexical n -> L : repeat n R ++ L Lexical n -> L : replicate n R ++ [L]
CApp e f -> N2 (copyToNock f) (copyToNock e) 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 -- | The proposed new calling convention
new :: Exp a -> Nock copy :: Ord a => Exp a -> Nock
new = go \v -> error "new: free variable" copy = copyToNock . toCopy
where
go = undefined
-- x. y. x -- x. y. x