Commit | Line | Data |
---|---|---|
6c47cf67 PS |
1 | module Core |
2 | ||
50bb9060 | 3 | open System |
a836d8f3 | 4 | open Types |
6c47cf67 | 5 | |
f877bf26 | 6 | let inline toBool b = if b then Node.TRUE else Node.FALSE |
6c47cf67 | 7 | |
a836d8f3 PS |
8 | let inline twoNumberOp (f : int64 -> int64 -> Node) = function |
9 | | [Number(a); Number(b)] -> f a b | |
6d809e32 PS |
10 | | [_; _] -> raise <| Error.argMismatch () |
11 | | _ -> raise <| Error.wrongArity () | |
a836d8f3 PS |
12 | |
13 | let inline twoNodeOp (f : Node -> Node -> Node) = function | |
14 | | [a; b] -> f a b | |
6d809e32 | 15 | | _ -> raise <| Error.wrongArity () |
a836d8f3 PS |
16 | |
17 | let add = twoNumberOp (fun a b -> a + b |> Number) | |
18 | let subtract = twoNumberOp (fun a b -> a - b |> Number) | |
19 | let multiply = twoNumberOp (fun a b -> a * b |> Number) | |
20 | let divide = twoNumberOp (fun a b -> a / b |> Number) | |
21 | let lt = twoNodeOp (fun a b -> a < b |> toBool) | |
22 | let le = twoNodeOp (fun a b -> a <= b |> toBool) | |
23 | let ge = twoNodeOp (fun a b -> a >= b |> toBool) | |
24 | let gt = twoNodeOp (fun a b -> a > b |> toBool) | |
7822be33 | 25 | let eq = twoNodeOp (fun a b -> a = b |> toBool) |
6c47cf67 | 26 | |
50bb9060 JM |
27 | let time_ms _ = |
28 | DateTime.Now.Ticks / TimeSpan.TicksPerMillisecond |> int64 |> Number | |
29 | ||
a71aefe1 | 30 | let list = Node.makeList |
a836d8f3 | 31 | let isList = function |
a71aefe1 | 32 | | [List(_, _)] -> Node.TRUE |
f877bf26 | 33 | | [_] -> Node.FALSE |
6d809e32 | 34 | | _ -> raise <| Error.wrongArity () |
6c47cf67 | 35 | |
a836d8f3 | 36 | let isEmpty = function |
a71aefe1 PS |
37 | | [List(_, [])] -> Node.TRUE |
38 | | [Vector(_, seg)] when seg.Count <= 0 -> Node.TRUE | |
f877bf26 | 39 | | _ -> Node.FALSE |
6c47cf67 | 40 | |
a836d8f3 | 41 | let count = function |
a71aefe1 PS |
42 | | [List(_, lst)] -> lst |> List.length |> int64 |> Number |
43 | | [Vector(_, seg)] -> seg.Count |> int64 |> Number | |
f877bf26 | 44 | | [Nil] -> Node.ZERO |
6d809e32 PS |
45 | | [_] -> raise <| Error.argMismatch () |
46 | | _ -> raise <| Error.wrongArity () | |
6a4627fb PS |
47 | |
48 | let pr_str nodes = nodes |> Printer.pr_str |> String | |
49 | let str nodes = nodes |> Printer.str |> String | |
50 | let prn nodes = nodes |> Printer.prn |> printfn "%s"; Nil | |
51 | let println nodes = nodes |> Printer.println |> printfn "%s"; Nil | |
8d4a06e0 PS |
52 | |
53 | let read_str = function | |
54 | | [String(s)] -> | |
55 | match Reader.read_str s with | |
56 | | [node] -> node | |
a71aefe1 | 57 | | nodes -> Symbol("do")::nodes |> Node.makeList |
6d809e32 PS |
58 | | [_] -> raise <| Error.argMismatch () |
59 | | _ -> raise <| Error.wrongArity () | |
8d4a06e0 PS |
60 | |
61 | let slurp = function | |
62 | | [String(s)] -> System.IO.File.ReadAllText s |> String | |
6d809e32 PS |
63 | | [_] -> raise <| Error.argMismatch () |
64 | | _ -> raise <| Error.wrongArity () | |
aa2e1438 PS |
65 | |
66 | let cons = function | |
a71aefe1 PS |
67 | | [node; List(_, lst)] -> node::lst |> Node.makeList |
68 | | [node; Vector(_, seg)] -> node::(List.ofSeq seg) |> Node.makeList | |
6d809e32 PS |
69 | | [_; _] -> raise <| Error.argMismatch () |
70 | | _ -> raise <| Error.wrongArity () | |
aa2e1438 PS |
71 | |
72 | let concat nodes = | |
aac99bed PS |
73 | let cons st node = node::st |
74 | let accumNode acc = function | |
a71aefe1 PS |
75 | | List(_, lst) -> lst |> List.fold cons acc |
76 | | Vector(_, seg) -> seg |> Seq.fold cons acc | |
6d809e32 | 77 | | _ -> raise <| Error.argMismatch () |
aac99bed | 78 | |
aa2e1438 | 79 | nodes |
aac99bed PS |
80 | |> List.fold accumNode [] |
81 | |> List.rev | |
a71aefe1 | 82 | |> Node.makeList |
f0e1608b PS |
83 | |
84 | let nth = function | |
a71aefe1 | 85 | | [List(_, lst); Number(n)] -> |
f0e1608b PS |
86 | let rec nth_list n = function |
87 | | [] -> raise <| Error.indexOutOfBounds () | |
88 | | h::_ when n = 0L -> h | |
89 | | _::t -> nth_list (n - 1L) t | |
90 | nth_list n lst | |
a71aefe1 | 91 | | [Vector(_, seg); Number(n)] -> |
f0e1608b PS |
92 | if n < 0L || n >= int64(seg.Count) then |
93 | raise <| Error.indexOutOfBounds () | |
94 | else | |
95 | seg.Array.[int(n)] | |
96 | | [_; _] -> raise <| Error.argMismatch () | |
97 | | _ -> raise <| Error.wrongArity () | |
98 | ||
99 | let first = function | |
a71aefe1 PS |
100 | | [List(_, [])] -> Node.NIL |
101 | | [List(_, h::_)] -> h | |
102 | | [Vector(_, seg)] when seg.Count > 0 -> seg.Array.[0] | |
103 | | [Vector(_, _)] -> Node.NIL | |
f0e1608b PS |
104 | | [Nil] -> Node.NIL |
105 | | [_] -> raise <| Error.argMismatch () | |
106 | | _ -> raise <| Error.wrongArity () | |
107 | ||
108 | let rest = function | |
a71aefe1 PS |
109 | | [List(_, [])] -> Node.EmptyLIST |
110 | | [List(_, _::t)] -> t |> Node.makeList | |
111 | | [Vector(_, seg)] when seg.Count < 2 -> Node.EmptyLIST | |
112 | | [Vector(_, seg)] -> seg |> Seq.skip 1 |> List.ofSeq |> Node.makeList | |
283779ea | 113 | | [Nil] -> Node.EmptyLIST |
f0e1608b PS |
114 | | [_] -> raise <| Error.argMismatch () |
115 | | _ -> raise <| Error.wrongArity () | |
224d2396 PS |
116 | |
117 | let throw = function | |
118 | | [node] -> raise <| Error.MalError(node) | |
119 | | _ -> raise <| Error.wrongArity () | |
120 | ||
121 | let map = function | |
a71aefe1 PS |
122 | | [BuiltInFunc(_, _, f); Node.Seq seq] |
123 | | [Func(_, _, f, _, _, _); Node.Seq seq] -> | |
124 | seq |> Seq.map (fun node -> f [node]) |> List.ofSeq |> Node.makeList | |
224d2396 PS |
125 | | [_; _] -> raise <| Error.argMismatch () |
126 | | _ -> raise <| Error.wrongArity () | |
127 | ||
128 | let apply = function | |
a71aefe1 PS |
129 | | BuiltInFunc(_, _, f)::rest |
130 | | Func(_, _, f, _, _, _)::rest -> | |
224d2396 PS |
131 | let rec getArgsAndCall acc = function |
132 | | [] -> raise <| Error.wrongArity () | |
133 | | [Node.Seq seq] -> | |
134 | seq |> Seq.fold (fun acc node -> node::acc) acc |> List.rev |> f | |
135 | | [_] -> raise <| Error.argMismatch () | |
136 | | h::rest -> getArgsAndCall (h::acc) rest | |
137 | getArgsAndCall [] rest | |
138 | | _::_ -> raise <| Error.argMismatch () | |
139 | | [] -> raise <| Error.wrongArity () | |
140 | ||
141 | let isConst cmp = function | |
142 | | [node] -> if node = cmp then Node.TRUE else Node.FALSE | |
143 | | _ -> raise <| Error.wrongArity () | |
144 | ||
0fb8a944 PS |
145 | let isPattern f = function |
146 | | [node] -> if f node then Node.TRUE else Node.FALSE | |
147 | | _ -> raise <| Error.wrongArity () | |
148 | ||
149 | let isSymbol = isPattern (function Symbol(_) -> true | _ -> false) | |
150 | let isKeyword = isPattern (function Keyword(_) -> true | _ -> false) | |
7b25f92c | 151 | let isString = isPattern (function String(_) -> true | _ -> false) |
9968eecb DM |
152 | let isNumber = isPattern (function Number(_) -> true | _ -> false) |
153 | let isFn = isPattern (function BuiltInFunc(_, _, _) | Func(_, _, _, _, _, _) -> true | _ -> false) | |
154 | let isMacro = isPattern (function Macro(_, _, _, _, _, _) -> true | _ -> false) | |
0fb8a944 | 155 | let isSequential = isPattern (function Node.Seq(_) -> true | _ -> false) |
a71aefe1 PS |
156 | let isVector = isPattern (function Vector(_, _) -> true | _ -> false) |
157 | let isMap = isPattern (function Map(_, _) -> true | _ -> false) | |
158 | let isAtom = isPattern (function Atom(_, _) -> true | _ -> false) | |
0fb8a944 PS |
159 | |
160 | let fromString f = function | |
161 | | [String(str)] -> f str | |
162 | | [_] -> raise <| Error.argMismatch () | |
224d2396 | 163 | | _ -> raise <| Error.wrongArity () |
0fb8a944 PS |
164 | |
165 | let symbol = fromString (fun s -> Symbol(s)) | |
166 | let keyword = fromString (fun s -> Keyword(s)) | |
167 | let vector lst = lst |> Array.ofList |> Node.ofArray | |
168 | ||
169 | let rec getPairs lst = | |
170 | seq { | |
171 | match lst with | |
172 | | first::second::t -> | |
173 | yield first, second | |
174 | yield! getPairs t | |
175 | | [_] -> raise <| Error.expectedEvenNodeCount () | |
176 | | [] -> () | |
177 | } | |
178 | ||
179 | let mapOpN f = function | |
a71aefe1 | 180 | | Map(_, map)::rest -> f rest map |
0fb8a944 PS |
181 | | [_] -> raise <| Error.argMismatch () |
182 | | _ -> raise <| Error.wrongArity () | |
183 | ||
184 | let mapOp1 f = | |
185 | mapOpN (fun rest map -> | |
186 | match rest with | |
187 | | [v] -> f v map | |
188 | | _ -> raise <| Error.wrongArity ()) | |
189 | ||
190 | let mapOp0 f = | |
191 | mapOpN (fun rest map -> | |
192 | match rest with | |
193 | | [] -> f map | |
194 | | _ -> raise <| Error.wrongArity ()) | |
195 | ||
196 | let mapKV f = | |
a71aefe1 | 197 | mapOp0 (fun map -> map |> Map.toSeq |> Seq.map f |> List.ofSeq |> Node.makeList) |
0fb8a944 | 198 | |
a71aefe1 | 199 | let hashMap lst = lst |> getPairs |> Map.ofSeq |> Node.makeMap |
0fb8a944 PS |
200 | let assoc = mapOpN (fun rest map -> |
201 | rest | |
202 | |> getPairs | |
203 | |> Seq.fold (fun map (k, v) -> Map.add k v map) map | |
a71aefe1 | 204 | |> Node.makeMap) |
0fb8a944 PS |
205 | let dissoc = mapOpN (fun keys map -> |
206 | keys | |
207 | |> List.fold (fun map k -> Map.remove k map) map | |
a71aefe1 | 208 | |> Node.makeMap) |
0fb8a944 PS |
209 | let get = function |
210 | | [Nil; _] -> Node.NIL | |
211 | | _ as rest -> | |
212 | rest |> mapOp1 (fun key map -> | |
213 | match Map.tryFind key map with | |
214 | | Some(node) -> node | |
215 | | None -> Node.NIL) | |
216 | let containsKey key map = if Map.containsKey key map then Node.TRUE else Node.FALSE | |
217 | let contains = mapOp1 containsKey | |
218 | let keys = mapKV (fun (k, v) -> k) | |
219 | let vals = mapKV (fun (k, v) -> v) | |
66913ea4 PS |
220 | |
221 | let atom nextValue = function | |
222 | | [node] -> Atom((nextValue ()), ref node) | |
223 | | _ -> raise <| Error.wrongArity () | |
224 | ||
225 | let deref = function | |
226 | | [Atom(_, r)] -> !r | |
227 | | [_] -> raise <| Error.argMismatch () | |
228 | | _ -> raise <| Error.wrongArity () | |
229 | ||
230 | let reset = function | |
231 | | [Atom(_, r); node] -> | |
232 | r := node | |
233 | !r | |
234 | | [_; _] -> raise <| Error.argMismatch () | |
235 | | _ -> raise <| Error.wrongArity () | |
236 | ||
237 | let swap = function | |
238 | | Atom(_, r) | |
a71aefe1 | 239 | ::(BuiltInFunc(_, _, f) | Func(_, _, f, _, _, _)) |
66913ea4 PS |
240 | ::rest -> |
241 | r := f (!r::rest) | |
242 | !r | |
243 | | [_; _] -> raise <| Error.argMismatch () | |
244 | | _ -> raise <| Error.wrongArity () | |
a71aefe1 PS |
245 | |
246 | let conj = function | |
247 | | List(_, lst)::rest -> | |
248 | rest | |
249 | |> List.fold (fun lst node -> node::lst) lst | |
250 | |> Node.makeList | |
251 | | Vector(_, seg)::rest -> | |
252 | (* Might be nice to implement a persistent vector here someday. *) | |
253 | let cnt = List.length rest | |
254 | if cnt > 0 then | |
255 | let target : Node array = seg.Count + cnt |> Array.zeroCreate | |
256 | System.Array.Copy(seg.Array :> System.Array, seg.Offset, | |
257 | target :> System.Array, 0, seg.Count) | |
258 | let rec copyElem i = function | |
259 | | h::t -> | |
260 | Array.set target i h | |
261 | copyElem (i + 1) t | |
262 | | [] -> () | |
263 | copyElem (seg.Count) rest | |
264 | target |> Node.ofArray | |
265 | else | |
266 | seg |> Node.makeVector | |
267 | | [_; _] -> raise <| Error.argMismatch () | |
268 | | _ -> raise <| Error.wrongArity () | |
269 | ||
7b25f92c DM |
270 | let seq = function |
271 | | [Nil] -> Node.NIL | |
272 | | [List(_, [])] -> Node.NIL | |
273 | | [List(_, _) as l] -> l | |
274 | | [Vector(_, seg)] when seg.Count < 1 -> Node.NIL | |
275 | | [Vector(_, seg)] -> seg |> List.ofSeq |> Node.makeList | |
276 | | [String(s)] when String.length s < 1 -> Node.NIL | |
277 | | [String(s)] -> s |> Seq.map Node.ofChar |> List.ofSeq |> Node.makeList | |
278 | | [_] -> raise <| Error.argMismatch () | |
279 | | _ -> raise <| Error.wrongArity () | |
280 | ||
a71aefe1 PS |
281 | let withMeta = function |
282 | | [List(_, lst); m] -> List(m, lst) | |
283 | | [Vector(_, seg); m] -> Vector(m, seg) | |
284 | | [Map(_, map); m] -> Map(m, map) | |
285 | | [BuiltInFunc(_, tag, f); m] -> BuiltInFunc(m, tag, f) | |
286 | | [Func(_, tag, f, a, b, c); m] -> Func(m, tag, f, a, b, c) | |
287 | | [Macro(_, tag, f, a, b, c); m] -> Macro(m, tag, f, a, b, c) | |
288 | | [_; _] -> raise <| Error.argMismatch () | |
289 | | _ -> raise <| Error.wrongArity () | |
290 | ||
291 | let meta = function | |
292 | | [List(m, _)] | |
293 | | [Vector(m, _)] | |
294 | | [Map(m, _)] | |
295 | | [BuiltInFunc(m, _, _)] | |
296 | | [Func(m, _, _, _, _, _)] | |
297 | | [Macro(m, _, _, _, _, _)] -> m | |
298 | | [_] -> Node.NIL | |
299 | | _ -> raise <| Error.wrongArity () |