blob: 02b1bfba5f72b33efd809d749f7a55b53cf811b6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
(;module:
lux
(lux (data [bool "B/" Eq<Bool>]
[text "T/" Eq<Text>]
[number]
(coll [list "L/" Functor<List> Fold<List> Monoid<List>]
["s" set])))
(luxc (lang ["la" analysis]
["ls" synthesis])
(synthesizer ["&;" function])))
(def: #export (path pattern)
(-> la;Pattern ls;Path)
(case pattern
(^template [<from> <to>]
(<from> register)
(<to> register))
([#la;BindP #ls;BindP]
[#la;BoolP #ls;BoolP]
[#la;NatP #ls;NatP]
[#la;IntP #ls;IntP]
[#la;DegP #ls;DegP]
[#la;FracP #ls;FracP]
[#la;TextP #ls;TextP])
(#la;TupleP membersP)
(case (list;reverse membersP)
#;Nil
#ls;UnitP
(#;Cons singletonP #;Nil)
(path singletonP)
(#;Cons lastP prevsP)
(let [length (list;size membersP)
last-idx (n.dec length)
last-path (#ls;TupleP (#;Right last-idx) (path lastP))
[_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]]
[(n.dec current-idx)
(#ls;SeqP (#ls;TupleP (#;Left current-idx)
(path current-pattern))
next-path)])
[(n.dec last-idx) last-path]
prevsP)]
tuple-path))
(#la;VariantP tag num-tags memberP)
(let [last? (n.= (n.dec num-tags) tag)]
(#ls;VariantP (if last? (#;Right tag) (#;Left tag))
(path memberP)))))
(def: #export (weave leftP rightP)
(-> ls;Path ls;Path ls;Path)
(with-expansions [<default> (as-is (#ls;AltP leftP rightP))]
(case [leftP rightP]
[#ls;UnitP #ls;UnitP]
#ls;UnitP
(^template [<tag> <test>]
[(<tag> left) (<tag> right)]
(if (<test> left right)
leftP
<default>))
([#ls;BindP n.=]
[#ls;BoolP B/=]
[#ls;NatP n.=]
[#ls;IntP i.=]
[#ls;DegP d.=]
[#ls;FracP f.=]
[#ls;TextP T/=])
(^template [<tag> <side>]
[(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)]
(if (n.= left-idx right-idx)
(weave left-then right-then)
<default>))
([#ls;TupleP #;Left]
[#ls;TupleP #;Right]
[#ls;VariantP #;Left]
[#ls;VariantP #;Right])
[(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)]
(case (weave left-pre right-pre)
(#ls;AltP _ _)
<default>
weavedP
(#ls;SeqP weavedP (weave left-post right-post)))
_
<default>)))
|
