balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Prepare ADT generator for new error monad

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-04-16 17:31:38 +02:00
parent a0b450a34d
commit 12cbc9ca07
2 changed files with 28 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
src/stages/adt_generator/generator.raku
View File

@ -143,7 +143,7 @@ say "";
for $statements -> $statement {
say "$statement"
}
say "type 'a monad = 'a Simple_utils.Trace.result;;";
say "type ('a,'err) monad = ('a) Simple_utils.Trace.result;;";
say "let (>>?) v f = Simple_utils.Trace.bind f v;;";
say "let return v = Simple_utils.Trace.ok v;;";
say "open $moduleName;;";
@ -151,7 +151,7 @@ say "open $moduleName;;";
say "";
say "(* must be provided by one of the open or include statements: *)";
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly;;"; }
{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a, _) monad) -> state -> a $poly -> (state * new_a $poly , _) monad = fold_map__$poly;;"; }
say "";
for $adts.kv -> $index, $t {
@ -182,34 +182,34 @@ say ";;";
say "";
for $adts.list -> $t {
say "type 'state continue_fold_map__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> ('state * $t<newName>) monad ;";
say "type ('state, 'err) continue_fold_map__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> ('state * $t<newName> , 'err) monad ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'}) monad ;" }
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'} , 'err) monad ;" }
say ' };;';
}
say "type 'state continue_fold_map = \{";
say "type ('state , 'err) continue_fold_map = \{";
for $adts.list -> $t {
say " $t<name> : 'state continue_fold_map__$t<name> ;";
say " $t<name> : ('state , 'err) continue_fold_map__$t<name> ;";
}
say ' };;';
say "";
for $adts.list -> $t
{ say "type 'state fold_map_config__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> 'state continue_fold_map -> ('state * $t<newName>) monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__pre_state : 'state -> $t<name> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
{ say "type ('state , 'err) fold_map_config__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> ('state, 'err) continue_fold_map -> ('state * $t<newName> , 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__pre_state : 'state -> $t<name> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> ('state, 'err) monad ;"; # (*Adt_info.node_instance_info ->*)
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> 'state continue_fold_map -> ('state * {$c<newType> || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state, 'err) continue_fold_map -> ('state * {$c<newType> || 'unit'} , 'err) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
}
say '};;' }
say "type 'state fold_map_config =";
say "type ('state, 'err) fold_map_config =";
say ' {';
for $adts.list -> $t
{ say " $t<name> : 'state fold_map_config__$t<name>;" }
{ say " $t<name> : ('state, 'err) fold_map_config__$t<name>;" }
say ' };;';
say "";
@ -371,31 +371,31 @@ for $adts.list -> $t
say "";
say "type 'state mk_continue_fold_map = \{";
say " fn : 'state mk_continue_fold_map -> 'state fold_map_config -> 'state continue_fold_map";
say "type ('state, 'err) mk_continue_fold_map = \{";
say " fn : ('state,'err) mk_continue_fold_map -> ('state, 'err) fold_map_config -> ('state , 'err) continue_fold_map";
say '};;';
# fold_map functions
say "";
for $adts.list -> $t
{ say "let _fold_map__$t<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
{ say "let _fold_map__$t<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>, err) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : (qstate,err) continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " visitor.$t<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " return (state, new_x);;";
say "";
for $t<ctorsOrFields>.list -> $c
{ say "let _fold_map__$t<name>__$c<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
{ say "let _fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) mk_continue_fold_map -> (qstate,err) fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }, err) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : (qstate,err) continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
say ""; } }
# make the "continue" object
say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "let mk_continue_fold_map : 'state . 'state mk_continue_fold_map = \{ fn = fun self visitor ->";
say "let mk_continue_fold_map : 'state 'err . ('state,'err) mk_continue_fold_map = \{ fn = fun self visitor ->";
say ' {';
for $adts.list -> $t
{ say " $t<name> = \{";
@ -410,16 +410,16 @@ say "";
# fold_map functions : tying the knot
say "";
for $adts.list -> $t
{ say "let fold_map__$t<name> : type qstate . qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad =";
{ say "let fold_map__$t<name> : type qstate err . (qstate,err) fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>,err) monad =";
say " fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
for $t<ctorsOrFields>.list -> $c
{ say "let fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad =";
{ say "let fold_map__$t<name>__$c<name> : type qstate err . (qstate,err) fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' },err) monad =";
say " fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x;;"; } }
for $adts.list -> $t
{
say "let no_op_node__$t<name> : type state . state -> $t<name> -> state continue_fold_map -> (state * $t<newName>) monad =";
say "let no_op_node__$t<name> : type state . state -> $t<name> -> (state,_) continue_fold_map -> (state * $t<newName>,_) monad =";
say " fun state v continue ->"; # (*_info*)
say " match v with";
if ($t<kind> eq $variant) {
@ -446,7 +446,7 @@ for $adts.list -> $t
}
for $adts.list -> $t
{ say "let no_op__$t<name> : type state . state fold_map_config__$t<name> = \{";
{ say "let no_op__$t<name> : type state . (state,_) fold_map_config__$t<name> = \{";
say " node__$t<name> = no_op_node__$t<name>;";
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
@ -460,7 +460,7 @@ for $adts.list -> $t
say ") ;"; }
say ' }' }
say "let no_op : type state . state fold_map_config = \{";
say "let no_op : type state . (state,_) fold_map_config = \{";
for $adts.list -> $t
{ say " $t<name> = no_op__$t<name>;" }
say '};;';

4
src/test/adt_generator/use_a_fold.ml
View File

@ -58,8 +58,8 @@ let () =
(* Test that the same fold_map_config can be ascibed with different 'a type arguments *)
let _noi : int fold_map_config = no_op (* (fun _ -> ()) *)
let _nob : bool fold_map_config = no_op (* (fun _ -> ()) *)
let _noi : (int, [> error]) fold_map_config = no_op (* (fun _ -> ()) *)
let _nob : (bool, [> error]) fold_map_config = no_op (* (fun _ -> ()) *)
let () =
let some_root : root = A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ] in