Skip to content

Commit 94f8810

Browse files
z-silverz-silver
committed
Cut the knot
1 parent 08f681c commit 94f8810

2 files changed

Lines changed: 66 additions & 107 deletions

File tree

‎lib/Ast.ml‎

Lines changed: 44 additions & 93 deletions
Original file line numberDiff line numberDiff line change
@@ -9,13 +9,52 @@ module type EXPR = sig
99
val is_functor : t -> bool
1010
end
1111

12-
module type LANGUAGE = sig
13-
type 'declaration directive [@@deriving show]
14-
type extra_module_info [@@deriving show]
15-
end
16-
1712
type head = { name : string; arity : int } [@@deriving show, ord]
1813

14+
module ClauseF (Expr : EXPR) = struct
15+
type multi_declaration = head * decl * decl Location.with_location list
16+
[@@deriving show]
17+
18+
and ('directives, 'mods) signature_ref =
19+
| Named of string Location.with_location
20+
| Inlined of {
21+
declarations : multi_declaration Location.with_location list;
22+
directives : ('directives, 'mods) directive Location.with_location list;
23+
}
24+
[@@deriving show]
25+
26+
and ('directives, 'mods) directive =
27+
| Module of {
28+
name : string Location.with_location;
29+
signature : ('directives, 'mods) signature_ref option;
30+
declarations : multi_declaration Location.with_location list;
31+
directives : ('directives, 'mods) directive Location.with_location list;
32+
target_specific : 'mods;
33+
}
34+
| Signature of {
35+
name : string Location.with_location;
36+
declarations : multi_declaration Location.with_location list;
37+
directives : ('directives, 'mods) directive Location.with_location list;
38+
}
39+
| TargetSpecific of 'directives
40+
[@@deriving show]
41+
42+
and ('directives, 'mods) base =
43+
| MultiDeclaration of multi_declaration
44+
| Query of { name : string; arity : int; args : string list }
45+
| Directive of ('directives, 'mods) directive
46+
[@@deriving show]
47+
48+
and decl = {
49+
body : Expr.func Location.with_location list;
50+
original_arg_list : Expr.t list;
51+
}
52+
[@@deriving show]
53+
54+
and ('directives, 'mods) t = ('directives, 'mods) base Location.with_location
55+
[@@deriving show]
56+
end
57+
1958
module Expr = struct
2059
type func_label =
2160
string Location.with_location list * string Location.with_location
@@ -132,94 +171,6 @@ module Expr = struct
132171
| _ -> false
133172
end
134173

135-
type multi_declaration = head * decl * decl Location.with_location list
136-
[@@deriving show]
137-
138-
and ('language_specific, 'target_specific) signature_ref =
139-
| Named of string Location.with_location
140-
| Inlined of {
141-
declarations : multi_declaration Location.with_location list;
142-
directives :
143-
('language_specific, 'target_specific) directive Location.with_location
144-
list;
145-
}
146-
147-
and ('language_specific, 'target_specific) directive =
148-
| Module of {
149-
name : string Location.with_location;
150-
signature : ('language_specific, 'target_specific) signature_ref option;
151-
declarations : multi_declaration Location.with_location list;
152-
directives :
153-
('language_specific, 'target_specific) directive Location.with_location
154-
list;
155-
language_specific : 'language_specific;
156-
}
157-
| Signature of {
158-
name : string Location.with_location;
159-
declarations : multi_declaration Location.with_location list;
160-
directives :
161-
('language_specific, 'target_specific) directive Location.with_location
162-
list;
163-
}
164-
| TargetSpecific of 'target_specific
165-
166-
and ('language_specific, 'target_specific) base =
167-
| MultiDeclaration of multi_declaration
168-
| Query of { name : string; arity : int; args : string list }
169-
| Directive of ('language_specific, 'target_specific) directive
170-
[@@deriving show]
171-
172-
and decl = {
173-
body : Expr.func Location.with_location list;
174-
original_arg_list : Expr.t list;
175-
}
176-
[@@deriving show]
177-
178-
and ('language_specific, 'target_specific) t =
179-
('language_specific, 'target_specific) base Location.with_location
180-
[@@deriving show]
181-
182-
module type CLAUSE = sig
183-
module Target : LANGUAGE
184-
185-
type nonrec multi_declaration = multi_declaration
186-
187-
type nonrec t =
188-
(multi_declaration Target.directive, Target.extra_module_info) t
189-
190-
type nonrec signature_ref =
191-
(multi_declaration Target.directive, Target.extra_module_info) signature_ref
192-
193-
type nonrec directive =
194-
(multi_declaration Target.directive, Target.extra_module_info) directive
195-
196-
type nonrec base =
197-
(multi_declaration Target.directive, Target.extra_module_info) base
198-
199-
type nonrec decl = decl
200-
end
201-
202-
module ClauseF (Expr : EXPR) (Target : LANGUAGE) :
203-
CLAUSE with module Target = Target = struct
204-
module Target = Target
205-
206-
type nonrec multi_declaration = multi_declaration
207-
208-
type nonrec t =
209-
(multi_declaration Target.directive, Target.extra_module_info) t
210-
211-
type nonrec signature_ref =
212-
(multi_declaration Target.directive, Target.extra_module_info) signature_ref
213-
214-
type nonrec directive =
215-
(multi_declaration Target.directive, Target.extra_module_info) directive
216-
217-
type nonrec base =
218-
(multi_declaration Target.directive, Target.extra_module_info) base
219-
220-
type nonrec decl = decl
221-
end
222-
223174
module ParserClauseF (Expr : EXPR) = struct
224175
type base =
225176
| Declaration of decl

‎lib/compiler/Types.ml‎

Lines changed: 22 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -130,34 +130,41 @@ type initialization = {
130130
type 'a initialize_nested =
131131
initialization -> BatSet.String.t -> 'a t option -> string -> 'a t
132132

133-
module type COMPILER_CONFIG = sig
134-
module Clause : Ast.CLAUSE
135-
136-
type 'a runner = {
137-
step : Clause.t list * 'a t -> 'a t;
138-
initialize_nested : 'a initialize_nested;
139-
}
133+
type ('state, 'directives, 'mods) runner = {
134+
step : ('directives, 'mods) Ast.Clause.t list * 'state t -> 'state t;
135+
initialize_nested : 'state initialize_nested;
136+
}
140137

138+
module type COMPILER_CONFIG = sig
139+
type directives
140+
type mods
141141
type state
142142

143143
val initial_state : unit -> state
144-
val compile_clause : state runner -> Clause.t -> state t -> state t
144+
145+
val compile_clause :
146+
(state, directives, mods) runner ->
147+
(directives, mods) Ast.Clause.t ->
148+
state t ->
149+
state t
145150

146151
module Lookup : LookupS with type t = state t
147152
end
148153

149154
module type COMPILER = sig
150-
module Clause : Ast.CLAUSE
151-
155+
type directives
156+
type mods
152157
type state
153158

154-
val step : Clause.t list * state t -> state t
159+
val step : (directives, mods) Ast.Clause.t list * state t -> state t
155160
val initialize : initialization -> state t
156161
end
157162

158163
module Make (Config : COMPILER_CONFIG) :
159-
COMPILER with type state = Config.state with module Clause = Config.Clause =
160-
struct
164+
COMPILER
165+
with type state = Config.state
166+
with type directives = Config.directives
167+
with type mods = Config.mods = struct
161168
include Config
162169

163170
let initialize_nested ({ persist; filename; externals } : initialization)
@@ -193,7 +200,8 @@ struct
193200
let module_name = ModuleName.of_filepath filename in
194201
initialize_nested init BatSet.String.empty None module_name
195202

196-
let rec step : Clause.t list * state t -> state t = function
203+
let rec step : (directives, mods) Ast.Clause.t list * state t -> state t =
204+
function
197205
| [], compiler ->
198206
if not @@ FT.is_empty compiler.output then
199207
compiler.persist compiler.filename

0 commit comments

Comments
 (0)