Convert haskell style type signature to C

Viewed 97

I have a set of haskell type signature, similar to below: (for anyone that knows haskell, this is a monomorphised version of .. )

(t2 -> t3) -> (t1 -> t2) ->  t1 -> t3

And with the implicit parens (Conveniently, this is how my program currently stores the type signatures - as a tree.):

(t2 -> t3) -> ((t1 -> t2) -> (t1 -> t3))

I am looking for a programmatic way to convert this style of type signature to a C style type signature with function pointers. So far, all I have been able to find is resources concerning one, maybe two levels of function pointers - Obviously, in this case, I need it to support theoretically infinite levels. Any resources or pointers would be helpful.

Thank you in advance.

EDIT: Encoding the type as a C datastructure would also work.

2 Answers

If @Dmitry's comment accurately reflects what you're trying to do, the Haskell code to perform such a conversion is surprisingly simple:

data HType = (:->) HType HType | H String
  deriving (Show)
infixr 0 :->

ctype :: String -> HType -> String
ctype x (a :-> b) = ctype ("(*" ++ x ++ ")(" ++ ctype "" a ++ ")") b
ctype "" (H a) = a
ctype x  (H a) = a ++ " " ++ x

main = do
  let t = (H "t2" :-> H "t3") :-> (H "t1" :-> H "t2") :-> H "t1" :-> H "t3"
  putStrLn $ ctype "compose" t

For this example, it produces the type signature:

t3 (*(*(*compose)(t3 (*)(t2)))(t2 (*)(t1)))(t1)

which does, indeed, describe a type compose that's a pointer to a function that accepts a pointer to a function t2 -> t3, returning a pointer to a function that accepts a pointer to a function t1 -> t2 that returns a pointer to a function t1 -> t3.

It's a little hard to see how such a type could be used. I mean, if you want to emit code for a compose function that could actually be assigned to such a pointer, it's tough to do without first-class functions. As a proof of concept, here's a non-reentrant version using global variables that proves that the type "works":

#include <stdio.h>

/* some concrete types to use */
typedef char t1;
typedef int t2;
typedef char* t3;

/* compose :: (t2 -> t3) -> ((t1 -> t2) -> (t1 -> t3)) */
typedef t3 (*(*(*compose)(t3 (*)(t2)))(t2 (*)(t1)))(t1);

/* code defining a `do_compose` function pointer of C type `compose` */

t3 (*f1)(t2);
t2 (*f2)(t1);

t3 compose2(t1 x)
{
        return (*f1)((*f2)(x));
}

t3 (*compose1(t2 (*g)(t1)))(t1)
{
        f2 = g;
        return compose2;
}

t3 (*(*compose0(t3 (*f)(t2)))(t2 (*)(t1)))(t1)
{
        f1 = f;
        return compose1;
}

compose do_compose = compose0;

/*
 * a test case for `do_compose`
 */

/* ord :: t1 -> t2 */
int ord(char c)
{
        return (int)c;
}

/* print :: t2 -> t3 */
char* print(int i)
{
        static char buffer[256];
        sprintf(buffer, "%d", i);
        return buffer;
}

int main()
{
        puts(do_compose(print)(ord)('A'));
}

Alternatively, if you want an "uncurried" version of the type, which in this case would be:

t3 (*compose)(t3 (*)(t2), t2 (*)(t1), t1)

(i.e., compose is a pointer to a function that takes a pointer to a function t2 -> t3, a pointer to a function t1 -> t2, and a value of type t1 and then returns a value of type t3), the Haskell code still isn't too bad:

ctype' :: String -> HType -> String
ctype' "" (H a) = a
ctype' x (H a) = a ++ " " ++ x
ctype' x funcall = go [] funcall
  where go args (a :-> b) = go (ctype "" a : args) b
        go args b = ctype ("(*" ++ x ++ ")(" ++ intercalate ", " (reverse args) ++ ")") b

The resulting function is much more ergonomic for implementation in C:

/* compose :: (t2 -> t3) -> ((t1 -> t2) -> (t1 -> t3)), uncurried version */
typedef t3 (*compose)(t3 (*)(t2), t2 (*)(t1), t1);

t3 compose0(t3 (*f)(t2), t2 (*g)(t1), t1 x)
{
        return (*f)((*g)(x));
}

compose do_compose = compose0;

...

int main()
{
        puts(do_compose(print, ord, 'A'));
}

If you want a C data structure, this will do it (quick and dirty):

#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>

typedef struct type_s {
  enum { FUNCTION, VAR } kind;
  union {
    struct function_s {
      struct type_s *from;
      struct type_s *to;
    } function;
    int var_n;
  };
} TYPE;

TYPE *make_function(TYPE *from, TYPE *to) {
  TYPE *t = malloc(sizeof *t);
  t->kind = FUNCTION;
  t->function.from = from;
  t->function.to = to;
  return t;
}

TYPE *make_var(int n) {
  TYPE *t = malloc(sizeof *t);
  t->kind = VAR;
  t->var_n = n;
  return t;
}

void print(TYPE *t) {
  switch (t->kind) {
    case FUNCTION:
      printf("(");
      print(t->function.from);
      printf(" -> ");
      print(t->function.to);
      printf(")");
      break;
    case VAR:
      printf("t%d", t->var_n);
      break;
    default:
      printf("Bad type kind %d\n", t->kind);
      exit(1);
  }
}

typedef enum { LP, RP, ID, ARROW, END_INPUT } TOKEN;
static char *token_str[] = { "(", ")", "ID", "->", "<end>", };

static int scanned_id;
static int ch;

void get_next(void) {
  ch = getchar();
}

void require(int required) {
  if (ch != required) {
    fprintf(stderr, "Required %c, saw %c\n", required, ch);
  }
}

TOKEN scan(void) {
  while (isspace(ch)) get_next();
  switch (ch) {
    case '(':
      get_next();
      return LP;
    case ')':
      get_next();
      return RP;
    case '-':
      get_next();
      require('>');
      get_next();
      return ARROW;
    case 't':
      get_next();
      scanned_id = 0;
      while (isdigit(ch)) {
        scanned_id = scanned_id * 10 + (ch - '0');
        get_next();
      }
      return ID;
    case EOF:
      return END_INPUT;
    default:
      fprintf(stderr, "Bad char: %c (%d)\n", ch, ch);
      exit(1);
  }
}

/*
 * Grammar:
 * S -> expr $
 * expr -> term | term -> expr
 * term -> ID | LP expr RP
 */

TOKEN tok;

void advance(void) {
  tok = scan();
}

void match(TOKEN t) {
  if (tok != t) {
    fprintf(stderr, "Expected %s, found %s\n", token_str[t], token_str[tok]);
    exit(1);
  }
  advance();
}

TYPE *expr(void);
TYPE *term(void);

TYPE *parse(void) {
  TYPE *t = expr();
  match(END_INPUT);
  return t;
}

TYPE *expr(void) {
  TYPE *t = term();
  if (tok == ARROW) {
    advance();
    return make_function(t, expr());
  }
  return t;
}

TYPE *term(void) {
  if (tok == ID) {
    TYPE *t = make_var(scanned_id);
    advance();
    return t;
  }
  match(LP);
  TYPE *t = expr();
  match(RP);
  return t;
}

int main(void) {
  get_next();
  advance();
  TYPE *t = parse();
  print(t);
  printf("\n");
  return 0;
}
Related