Merge pull request #129 from pesco/h_bind

Add monadic bind combinator h_bind

src/SConscript

@@ -22,6 +22,7 @@ parsers = ['parsers/%s.c'%s for s in
            ['action',
             'and',
             'attr_bool',
+            'bind',
             'bits',
             'butnot',
             'ch',

src/hammer.h

@@ -123,6 +123,19 @@ typedef struct HParseResult_ {
  */
 typedef struct HBitWriter_ HBitWriter;
 
+typedef struct HCFChoice_ HCFChoice;
+typedef struct HRVMProg_ HRVMProg;
+typedef struct HParserVtable_ HParserVtable;
+
+// TODO: Make this internal
+typedef struct HParser_ {
+  const HParserVtable *vtable;
+  HParserBackend backend;
+  void* backend_data;
+  void *env;
+  HCFChoice *desugared; /* if the parser can be desugared, its desugared form */
+} HParser;
+
 /**
  * Type of an action to apply to an AST, used in the action() parser. 
  * It can be any (user-defined) function that takes a HParseResult*
@@ -142,18 +155,17 @@ typedef HParsedToken* (*HAction)(const HParseResult *p, void* user_data);
  */
 typedef bool (*HPredicate)(HParseResult *p, void* user_data);
 
-typedef struct HCFChoice_ HCFChoice;
-typedef struct HRVMProg_ HRVMProg;
-typedef struct HParserVtable_ HParserVtable;
-
-// TODO: Make this internal
-typedef struct HParser_ {
-  const HParserVtable *vtable;
-  HParserBackend backend;
-  void* backend_data;
-  void *env;
-  HCFChoice *desugared; /* if the parser can be desugared, its desugared form */
-} HParser;
+/**
+ * Type of a parser that depends on the result of a previous parser,
+ * used in h_bind(). The void* argument is passed through from h_bind() and can
+ * be used to arbitrarily parameterize the function further.
+ *
+ * The HAllocator* argument gives access to temporary memory and is to be used
+ * for any allocations inside the function. Specifically, construction of any
+ * HParsers should use the '__m' combinator variants with the given allocator.
+ * Anything allocated thus will be freed by 'h_bind'.
+ */
+typedef HParser* (*HContinuation)(HAllocator *mm__, const HParsedToken *x, void *env);
 
 // {{{ Stuff for benchmarking
 typedef struct HParserTestcase_ {
@@ -664,6 +676,17 @@ HAMMER_FN_DECL(HParser*, h_put_value, const HParser *p, const char* name);
  */
 HAMMER_FN_DECL(HParser*, h_get_value, const char* name);
 
+/**
+ * Monadic bind for HParsers, i.e.:
+ * Sequencing where later parsers may depend on the result(s) of earlier ones.
+ *
+ * Run p and call the result x. Then run k(env,x).  Fail if p fails or if
+ * k(env,x) fails or if k(env,x) is NULL.
+ *
+ * Result: the result of k(x,env).
+ */
+HAMMER_FN_DECL(HParser*, h_bind, const HParser *p, HContinuation k, void *env);
+
 /**
  * Free the memory allocated to an HParseResult when it is no longer needed.
  */

src/parsers/bind.c

@@ -0,0 +1,81 @@
+#include "parser_internal.h"
+
+typedef struct {
+    const HParser *p;
+    HContinuation k;
+    void *env;
+    HAllocator *mm__;
+} BindEnv;
+
+// an HAllocator backed by an HArena
+typedef struct {
+    HAllocator allocator;   // inherit  XXX is this the proper way to do it?
+    HArena *arena;
+} ArenaAllocator;
+
+static void *aa_alloc(HAllocator *allocator, size_t size)
+{
+    HArena *arena = ((ArenaAllocator *)allocator)->arena;
+    return h_arena_malloc(arena, size);
+}
+
+static void *aa_realloc(HAllocator *allocator, void *ptr, size_t size)
+{
+    HArena *arena = ((ArenaAllocator *)allocator)->arena;
+    assert(((void)"XXX need realloc for arena allocator", 0));
+    return NULL;
+}
+
+static void aa_free(HAllocator *allocator, void *ptr)
+{
+    HArena *arena = ((ArenaAllocator *)allocator)->arena;
+    h_arena_free(arena, ptr);
+}
+
+static HParseResult *parse_bind(void *be_, HParseState *state) {
+    BindEnv *be = be_;
+
+    HParseResult *res = h_do_parse(be->p, state);
+    if(!res)
+        return NULL;
+
+    // create a temporary arena allocator for the continuation
+    HArena *arena = h_new_arena(be->mm__, 0);
+    ArenaAllocator aa = {{aa_alloc, aa_realloc, aa_free}, arena};
+
+    HParser *kx = be->k((HAllocator *)&aa, res->ast, be->env);
+    if(!kx) {
+        h_delete_arena(arena);
+        return NULL;
+    }
+
+    res = h_do_parse(kx, state);
+
+    h_delete_arena(arena);
+    return res;
+}
+
+static const HParserVtable bind_vt = {
+    .parse = parse_bind,
+    .isValidRegular = h_false,
+    .isValidCF = h_false,
+    .compile_to_rvm = h_not_regular,
+};
+
+HParser *h_bind(const HParser *p, HContinuation k, void *env)
+{
+    return h_bind__m(&system_allocator, p, k, env);
+}
+
+HParser *h_bind__m(HAllocator *mm__,
+                   const HParser *p, HContinuation k, void *env)
+{
+    BindEnv *be = h_new(BindEnv, 1);
+
+    be->p = p;
+    be->k = k;
+    be->env = env;
+    be->mm__ = mm__;
+
+    return h_new_parser(mm__, &bind_vt, be);
+}

src/t_parser.c

@@ -568,6 +568,41 @@ static void test_permutation(gconstpointer backend) {
   g_check_parse_failed(po2, be, "ccc", 3);
 }
 
+static HParser *k_test_bind(HAllocator *mm__, const HParsedToken *p, void *env) {
+  uint8_t one = (uintptr_t)env;
+  
+  assert(p);
+  assert(p->token_type == TT_SEQUENCE);
+
+  int v=0;
+  for(size_t i=0; i<p->seq->used; i++) {
+    assert(p->seq->elements[i]->token_type == TT_UINT);
+    v = v*10 + p->seq->elements[i]->uint - '0';
+  }
+
+  if(v > 26)
+    return h_nothing_p__m(mm__);	// fail
+  else if(v > 127)
+    return NULL;			// equivalent to the above
+  else
+    return h_ch__m(mm__, one - 1 + v);
+}
+static void test_bind(gconstpointer backend) {
+  HParserBackend be = (HParserBackend)GPOINTER_TO_INT(backend);
+  const HParser *digit = h_ch_range('0', '9');
+  const HParser *nat = h_many1(digit);
+  const HParser *p = h_bind(nat, k_test_bind, (void *)(uintptr_t)'a');
+
+  g_check_parse_match(p, be, "1a", 2, "u0x61");
+  g_check_parse_match(p, be, "2b", 2, "u0x62");
+  g_check_parse_match(p, be, "26z", 3, "u0x7a");
+  g_check_parse_failed(p, be, "1x", 2);
+  g_check_parse_failed(p, be, "29y", 3);
+  g_check_parse_failed(p, be, "@", 1);
+  g_check_parse_failed(p, be, "27{", 3);
+  g_check_parse_failed(p, be, "272{", 4);
+}
+
 void register_parser_tests(void) {
   g_test_add_data_func("/core/parser/packrat/token", GINT_TO_POINTER(PB_PACKRAT), test_token);
   g_test_add_data_func("/core/parser/packrat/ch", GINT_TO_POINTER(PB_PACKRAT), test_ch);
@@ -617,6 +652,7 @@ void register_parser_tests(void) {
   g_test_add_data_func("/core/parser/packrat/endianness", GINT_TO_POINTER(PB_PACKRAT), test_endianness);
   g_test_add_data_func("/core/parser/packrat/putget", GINT_TO_POINTER(PB_PACKRAT), test_put_get);
   g_test_add_data_func("/core/parser/packrat/permutation", GINT_TO_POINTER(PB_PACKRAT), test_permutation);
+  g_test_add_data_func("/core/parser/packrat/bind", GINT_TO_POINTER(PB_PACKRAT), test_bind);
 
   g_test_add_data_func("/core/parser/llk/token", GINT_TO_POINTER(PB_LLk), test_token);
   g_test_add_data_func("/core/parser/llk/ch", GINT_TO_POINTER(PB_LLk), test_ch);