Source file Eval.ml
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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
open Base
module LexEnv = Algaeff.Reader.Make (struct type env = Sem.t Env.t end)
module DynEnv = Algaeff.Reader.Make (struct type env = Sem.t Env.t end)
module TrIx = Algaeff.Reader.Make (struct type env = int end)
let rec eval : Syn.t -> Sem.t =
function
| [] -> []
| Link {title; dest} :: rest ->
let title = eval title in
let link = Sem.Link {dest; title} in
link :: eval rest
| Math (mmode, e) :: rest ->
Sem.Math (mmode, eval e) :: eval rest
| Tag name :: rest ->
eval_tag name rest
| Transclude (tmode, name) :: rest ->
Sem.Transclude (TrIx.read (), tmode, name) ::
begin
TrIx.scope Int.succ @@ fun () ->
eval rest
end
| EmbedTeX {packages; source} :: rest ->
Sem.EmbedTeX {packages; source = eval source} :: eval rest
| Block (title, body) :: rest ->
Sem.Block (eval title, eval body) :: eval rest
| Lam (xs, body) :: rest ->
let rec loop xs rest =
match xs, rest with
| [], rest -> eval body, rest
| x :: xs, Syn.Group (Braces, u) :: rest ->
LexEnv.scope (Env.add x (eval u)) @@ fun () ->
loop xs rest
| _ ->
failwith "eval/Lam"
in
let body, rest = loop xs rest in
body @ eval rest
| Var x :: rest ->
begin
match Env.find_opt x @@ LexEnv.read () with
| None -> failwith @@ Format.asprintf "Could not find variable named %a" Symbol.pp x
| Some v -> v @ eval rest
end
| Put (k, v, body) :: rest ->
let body =
DynEnv.scope (Env.add k @@ eval v) @@ fun () ->
eval body
in
body @ eval rest
| Default (k, v, body) :: rest ->
let body =
let upd flenv = if Env.mem k flenv then flenv else Env.add k (eval v) flenv in
DynEnv.scope upd @@ fun () ->
eval body
in
body @ eval rest
| Get key :: rest ->
begin
match Env.find_opt key @@ DynEnv.read () with
| None -> failwith @@ Format.asprintf "Could not find fluid binding named %a" Symbol.pp key
| Some v -> v @ eval rest
end
| (Group _ :: _ | Text _ :: _) as rest->
eval_textual [] rest
and eval_textual prefix : Syn.t -> Sem.t =
function
| Group (d, xs) :: rest ->
let l, r =
match d with
| Braces -> "{", "}"
| Squares -> "[", "]"
| Parens -> "(", ")"
in
eval_textual (l :: prefix) @@ xs @ Text r :: rest
| Text x :: rest ->
eval_textual (x :: prefix) @@ rest
| rest ->
let txt = String.concat "" @@ List.rev prefix in
Text txt :: eval rest
and eval_no_op ~env ~flenv msg =
function
| Syn.Group (Braces, _) :: rest ->
eval rest
| _ -> failwith msg
and eval_tag name =
function
| Syn.Group (Braces, u) :: rest ->
let u' = eval u in
Sem.Tag (name, u') :: eval rest
| rest ->
Sem.Tag (name, []) :: eval rest
let eval_doc (doc : Syn.doc) : Sem.doc =
let fm, tree = doc in
LexEnv.run ~env:Env.empty @@ fun () ->
DynEnv.run ~env:Env.empty @@ fun () ->
TrIx.run ~env:1 @@ fun () ->
let tree = eval tree in
let title = Option.map eval fm.title in
let metas =
fm.metas |> List.map @@ fun (k, v) ->
k, eval v
in
let open Sem in
{title;
body = tree;
addr = fm.addr;
taxon = fm.taxon;
authors = fm.authors;
date = fm.date;
metas}