@@ -0,0 +1,249 @@
1+module Urbit.Deconstructor exposing
2+ ( Deconstructor
3+ , alt
4+ , bytes
5+ , cell
6+ , const
7+ , cord
8+ , float32
9+ , float64
10+ , int
11+ , list
12+ , llec
13+ , map
14+ , oneOf
15+ , run
16+ , runBytes
17+ , sig
18+ , signedInt
19+ , tape
20+ , tar
21+ )
22+
23+import Bitwise
24+import Bytes exposing (Bytes, Endianness(..))
25+import Bytes.Decode as BD
26+import Bytes.Extra
27+import Urbit exposing (..)
28+
29+
30+type Deconstructor a b
31+ = Deconstructor (Noun -> a -> Maybe b)
32+
33+
34+run : Deconstructor (a -> a) a -> Noun -> Maybe a
35+run (Deconstructor f) noun =
36+ f noun identity
37+
38+
39+runBytes : Deconstructor (a -> a) a -> Bytes -> Maybe a
40+runBytes (Deconstructor f) bs =
41+ cue bs
42+ |> Maybe.andThen
43+ (\noun -> f noun identity)
44+
45+
46+const : Deconstructor (a -> a) a -> a -> Deconstructor c c
47+const (Deconstructor f) value =
48+ Deconstructor
49+ (\noun c ->
50+ case f noun identity of
51+ Just a ->
52+ if a == value then
53+ Just c
54+
55+ else
56+ Nothing
57+
58+ Nothing ->
59+ Nothing
60+ )
61+
62+
63+cord : Deconstructor (String -> a) a
64+cord =
65+ Deconstructor
66+ (\x f ->
67+ case x of
68+ Atom bs ->
69+ BD.decode (BD.string (Bytes.width bs)) bs
70+ |> Maybe.map f
71+
72+ Cell _ ->
73+ Nothing
74+ )
75+
76+
77+tape : Deconstructor (String -> a) a
78+tape =
79+ list cord |> fmap String.concat
80+
81+
82+int : Deconstructor (Int -> a) a
83+int =
84+ Deconstructor
85+ (\x f ->
86+ case x of
87+ Atom bs ->
88+ Bytes.Extra.toByteValues bs
89+ |> List.foldr
90+ (\b acc -> Bitwise.shiftLeftBy 8 acc |> Bitwise.or b)
91+ 0
92+ |> f
93+ |> Just
94+
95+ Cell _ ->
96+ Nothing
97+ )
98+
99+
100+signedInt : Deconstructor (Int -> a) a
101+signedInt =
102+ int
103+ |> fmap
104+ (\i ->
105+ if Bitwise.and 1 i == 1 then
106+ -(Bitwise.shiftRightBy 1 (1 + i))
107+
108+ else
109+ Bitwise.shiftRightBy 1 i
110+ )
111+
112+
113+float32 : Deconstructor (Float -> a) a
114+float32 =
115+ Deconstructor
116+ (\x f ->
117+ case x of
118+ Atom bs ->
119+ BD.decode (BD.float32 LE) bs
120+ |> Maybe.map f
121+
122+ Cell _ ->
123+ Nothing
124+ )
125+
126+
127+float64 : Deconstructor (Float -> a) a
128+float64 =
129+ Deconstructor
130+ (\x f ->
131+ case x of
132+ Atom bs ->
133+ BD.decode (BD.float64 LE) bs
134+ |> Maybe.map f
135+
136+ Cell _ ->
137+ Nothing
138+ )
139+
140+
141+bytes : Deconstructor (Bytes -> a) a
142+bytes =
143+ Deconstructor
144+ (\n f ->
145+ case n of
146+ Atom bs ->
147+ f bs |> Just
148+
149+ Cell _ ->
150+ Nothing
151+ )
152+
153+
154+sig : Deconstructor a a
155+sig =
156+ Deconstructor
157+ (\n a ->
158+ case n of
159+ Atom b ->
160+ if (Bytes.Extra.toByteValues b |> List.filter (\x -> x /= 0)) == [] then
161+ Just a
162+
163+ else
164+ Nothing
165+
166+ Cell _ ->
167+ Nothing
168+ )
169+
170+
171+list : Deconstructor (a -> a) a -> Deconstructor (List a -> b) b
172+list (Deconstructor f) =
173+ Deconstructor
174+ (\n g ->
175+ let
176+ go n_ =
177+ case n_ of
178+ Atom _ ->
179+ Just []
180+
181+ Cell ( el, tail ) ->
182+ Maybe.map2 (\a b -> a :: b) (f el identity) (go tail)
183+ in
184+ go n |> Maybe.map g
185+ )
186+
187+
188+alt : Deconstructor a b -> Deconstructor a b -> Deconstructor a b
189+alt (Deconstructor f) (Deconstructor g) =
190+ Deconstructor
191+ (\n a ->
192+ case f n a of
193+ Just x ->
194+ Just x
195+
196+ Nothing ->
197+ g n a
198+ )
199+
200+
201+oneOf : List (Deconstructor a b) -> Deconstructor a b
202+oneOf l =
203+ case l of
204+ [] ->
205+ Deconstructor (\_ _ -> Nothing)
206+
207+ x :: xs ->
208+ alt x (oneOf xs)
209+
210+
211+tar : Deconstructor a a
212+tar =
213+ Deconstructor (\_ a -> Just a)
214+
215+
216+llec : Deconstructor a b -> Deconstructor b c -> Deconstructor a c
217+llec (Deconstructor r) (Deconstructor l) =
218+ Deconstructor
219+ (\noun a ->
220+ case noun of
221+ Cell ( lhs, rhs ) ->
222+ r rhs a |> Maybe.andThen (\b -> l lhs b)
223+
224+ Atom _ ->
225+ Nothing
226+ )
227+
228+
229+cell : Deconstructor a b -> Deconstructor b c -> Deconstructor a c
230+cell (Deconstructor l) (Deconstructor r) =
231+ Deconstructor
232+ (\noun a ->
233+ case noun of
234+ Cell ( lhs, rhs ) ->
235+ l lhs a |> Maybe.andThen (\b -> r rhs b)
236+
237+ Atom _ ->
238+ Nothing
239+ )
240+
241+
242+map : a -> Deconstructor a b -> Deconstructor (b -> c) c
243+map a (Deconstructor f) =
244+ Deconstructor (\noun g -> f noun a |> Maybe.map g)
245+
246+
247+fmap : (a -> b) -> Deconstructor (a -> c) c -> Deconstructor (b -> c) c
248+fmap f (Deconstructor g) =
249+ Deconstructor (\noun h -> g noun (f >> h))