#include #include typedef char bool; const bool false = 0, true = 1; enum context {pcm_params, params_only}; void make_camel_case (char *dst, const char *src) { while (*src != 0) { if (*src == '_') { src ++; if (*src == 0) {break;} *dst = *src - ('a'-'A'); // assumes that 'a'>'A' } else { *dst = *src; } src++; dst++; } *dst = 0; } void init_comma (bool *comma) { *comma = false; } void print_comma (bool *comma) { if (*comma) { printf(", "); } *comma = true; } struct type { char *convert; char *hsname; char *cname; }; enum param_direction {dir_in, dir_out, dir_inout}; struct parameter { struct type *type; char *name; enum param_direction dir; }; struct parameter *in (struct type* t, char *name) { struct parameter *p = malloc (sizeof(struct parameter)); p->type = t; p->name = name; p->dir = dir_in; return p; } struct parameter *out (struct type* t, char *name) { struct parameter *p = malloc (sizeof(struct parameter)); p->type = t; p->name = name; p->dir = dir_out; return p; } struct parameter *inout (struct type* t, char *name) { struct parameter *p = malloc (sizeof(struct parameter)); p->type = t; p->name = name; p->dir = dir_inout; return p; } struct type bool_p = {"boolConv", "Bool", "Bool_"}; struct type uint_p = {"Conv.int", "Word", "C.CUInt"}; struct type rate_p = {"Conv.int", "SampleFreq", "C.CUInt"}; struct type time_p = {"Conv.int", "Time", "C.CUInt"}; struct type direction_p = {"ordConv", "Ordering", "Direction"}; struct type uframes_p = {"Conv.int", "Size", "C.CUInt"}; struct type access_p = {"Conv.id", "Access", "Access"}; struct type format_p = {"Conv.id", "Format", "Format"}; struct type subformat_p = {"Conv.id", "Subformat", "Subformat"}; enum result {noresult, boolresult, uintresult, errnoresult, checked}; void hsc_accessor (enum result res, const char *name, enum context ctx, ...) { va_list arg; struct parameter *p; bool comma; char *camelName = alloca (strlen (name) + 1); make_camel_case (camelName, name); printf("foreign import ccall safe \"alsa/pcm.h snd_pcm_hw_params_%s\"\n", name); printf(" %s_ :: ", camelName); if (ctx==pcm_params) { // printf("Ptr (Struct i y) -> Ptr Params -> "); printf("Handle i y -> Ptr Params -> "); } else { printf("Ptr Params -> "); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir == dir_in) { printf("%s -> ", p->type->cname); } else { printf("Ptr %s -> ", p->type->cname); } } va_end (arg); printf("IO "); if (res == noresult) { printf("()"); } else if (res == errnoresult) { printf("E.Errno"); } else { printf("C.CInt"); } printf("\n\n"); printf("%s :: ", camelName); va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir != dir_out) { printf("%s -> ", p->type->hsname); } } va_end (arg); printf("T i y ("); init_comma(&comma); if (res == uintresult) { print_comma(&comma); printf("Word"); } else if (res == errnoresult) { print_comma(&comma); printf("E.Errno"); } else if (res == boolresult) { print_comma(&comma); printf("Bool"); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir != dir_in) { print_comma(&comma); printf("%s", p->type->hsname); } } va_end (arg); printf(")\n"); printf("%s", camelName); va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir != dir_out) { printf(" %s", p->name); } } va_end (arg); printf(" =\n"); if (ctx==pcm_params) { // printf(" Cons $ \\(Handle h) p ->\n"); printf(" Cons $ \\h p ->\n"); } else { printf(" Cons $ \\ _ p ->\n"); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir == dir_out) { printf(" alloca $ \\%sPtr ->\n", p->name); } else if (p->dir == dir_inout) { printf(" Conv.with %s %s $ \\%sPtr ->\n", p->type->convert, p->name, p->name); } } va_end (arg); printf(" %s_", camelName); if (ctx==pcm_params) { printf(" h p"); } else { printf(" p"); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir == dir_in) { printf(" (fromHaskell %s %s)", p->type->convert, p->name); } else { printf(" %sPtr", p->name); } } va_end (arg); if (res == uintresult) { printf(" >>=\n checkResult \"HwParams.%s\" >>= \\res ->\n", camelName); } else if (res == boolresult || res == errnoresult) { printf(" >>= \\res ->\n"); } else if (res == checked) { printf(" >>=\n checkResult_ \"HwParams.%s\" >>\n", camelName); } else { printf(" >>\n"); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir != dir_in) { printf(" Conv.peek %s %sPtr >>= \\%sResult ->\n", p->type->convert, p->name, p->name); } } va_end (arg); printf(" return ("); init_comma(&comma); if (res == uintresult) { print_comma(&comma); printf("fromIntegral res"); } else if (res == errnoresult) { print_comma(&comma); printf("res"); } else if (res == boolresult) { print_comma(&comma); printf("res/=0"); } va_start (arg, ctx); while (p = va_arg (arg, struct parameter *)) { if (p->dir != dir_in) { print_comma(&comma); printf("%sResult", p->name); } } va_end (arg); printf(")\n"); }