mirror of
https://github.com/comby-tools/comby.git
synced 2024-09-11 13:25:36 +03:00
map aliases in rules
This commit is contained in:
parent
0a29179410
commit
ef5d420739
@ -26,6 +26,17 @@ let map_template (module Parser : Types.Rule.S) template pattern match_template
|
|||||||
let rule' = append_rule (module Parser) rule parent_rule in
|
let rule' = append_rule (module Parser) rule parent_rule in
|
||||||
template', rule'
|
template', rule'
|
||||||
|
|
||||||
|
let rec map_atom (rule : Types.Ast.expression list) f =
|
||||||
|
let open Types.Ast in
|
||||||
|
List.map rule ~f:(function
|
||||||
|
| Equal (l, r) -> Equal (f l, f r)
|
||||||
|
| Not_equal (l, r) -> Not_equal (f l, f r)
|
||||||
|
| Match (e, l) ->
|
||||||
|
Match (f e, List.map l ~f:(fun (a, l) -> (f a, map_atom l f)))
|
||||||
|
| Rewrite (e, (l, r)) ->
|
||||||
|
Rewrite (f e, (f l, f r))
|
||||||
|
| t -> t)
|
||||||
|
|
||||||
let map_aliases
|
let map_aliases
|
||||||
(module Metasyntax : Metasyntax.S)
|
(module Metasyntax : Metasyntax.S)
|
||||||
(module External : External.S)
|
(module External : External.S)
|
||||||
@ -40,4 +51,15 @@ let map_aliases
|
|||||||
| None -> template, parent_rule
|
| None -> template, parent_rule
|
||||||
| Some _ -> map_template (module Parser) template pattern match_template rule parent_rule
|
| Some _ -> map_template (module Parser) template pattern match_template rule parent_rule
|
||||||
in
|
in
|
||||||
|
let parent_rule' =
|
||||||
|
let open Option in
|
||||||
|
parent_rule' >>| fun parent_rule' ->
|
||||||
|
map_atom parent_rule' (function
|
||||||
|
| Template t ->
|
||||||
|
Template (Parser.Template.parse
|
||||||
|
(String.substr_replace_all
|
||||||
|
(Parser.Template.to_string t) ~pattern ~with_:match_template))
|
||||||
|
| String s ->
|
||||||
|
String (String.substr_replace_all s ~pattern ~with_:match_template))
|
||||||
|
in
|
||||||
template', parent_rule')
|
template', parent_rule')
|
||||||
|
@ -49,7 +49,7 @@ module Make (Metasyntax : Types.Metasyntax.S) (External : Types.External.S) = st
|
|||||||
let match_rewrite_parser =
|
let match_rewrite_parser =
|
||||||
both
|
both
|
||||||
(spaces *> template_parser (spaces *> string "->"))
|
(spaces *> template_parser (spaces *> string "->"))
|
||||||
(option None (spaces *> string Syntax.arrow *> spaces *> template_parser (spaces1 *> string "where" *> spaces1) >>| fun v -> Some v)) (* FIXME use of reserved *)
|
(option None (spaces *> string Syntax.arrow *> spaces *> template_parser (spaces1 *> string "where" *> spaces1) >>| fun v -> Some v))
|
||||||
in
|
in
|
||||||
match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) ->
|
match_rewrite_parser >>= fun (match_template_atom, rewrite_template_atom) ->
|
||||||
(option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule ->
|
(option None (spaces1 *> Parser.parse >>| fun x -> Some x)) >>= fun rule ->
|
||||||
|
Loading…
Reference in New Issue
Block a user