ghc/compiler/yaccParser/type2context.c

   1 /**********************************************************************
   2 *                                                                     *
   3 *                                                                     *
   4 *      Convert Types to Contexts                                      *
   5 *                                                                     *
   6 *                                                                     *
   7 **********************************************************************/
   8
   9
  10 #include <stdio.h>
  11 #include "hspincl.h"
  12 #include "constants.h"
  13 #include "utils.h"
  14
  15 /*  Imported Values */
  16 extern list Lnil;
  17
  18 VOID is_context_format PROTO((ttype)); /* forward */
  19
  20 /*
  21     partain: see also the comment by "decl" in hsparser.y.
  22
  23     Here, we've been given a type that must be of the form
  24     "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
  25
  26     Convert it to a list.
  27 */
  28
  29
  30 list
  31 type2context(t)
  32   ttype t;
  33 {
  34     char *tycon_name;
  35     list  args, rest_args;
  36     ttype first_arg;
  37
  38     switch (tttype(t)) {
  39       case ttuple:
  40         /* returning the list is OK, but ensure items are right format */
  41         args = gttuple(t);
  42
  43         if (tlist(args) == lnil)
  44           hsperror ("type2context: () found instead of a context");
  45
  46         while (tlist(args) != lnil)
  47           {
  48             is_context_format(lhd(args));
  49             args = ltl(args);
  50           }
  51
  52         return(gttuple(t)); /* args */
  53
  54
  55       case tname :
  56         tycon_name = gtypeid(t);
  57
  58         /* just a class name ":: C =>" */
  59         if (tlist(gtypel(t)) == lnil)
  60             return (mklcons(t, Lnil));
  61
  62         /* should be just: ":: C a =>" */
  63         else
  64           {
  65             first_arg = (ttype) lhd(gtypel(t));
  66             rest_args = ltl(gtypel(t)); /* should be nil */
  67
  68             if (tlist(rest_args) != lnil)
  69               hsperror ("type2context: too many variables after class name");
  70
  71             switch (tttype(first_arg))
  72               {
  73                 case namedtvar: /* ToDo: right? */
  74                   return (mklcons(t, Lnil));
  75                   break;
  76
  77                 default:
  78                   hsperror ("type2context: something wrong with variable after class name");
  79               }
  80           }
  81         break;
  82
  83       case namedtvar:
  84         hsperror ("type2context: unexpected namedtvar found in a context");
  85
  86       case tllist:
  87         hsperror ("type2context: list constructor found in a context");
  88
  89       case tfun:
  90         hsperror ("type2context: arrow (->) constructor found in a context");
  91
  92       case context:
  93         hsperror ("type2context: unexpected context-thing found in a context");
  94
  95       default    :
  96         hsperror ("type2context: totally unexpected input");
  97     }
  98     abort(); /* should never get here! */
  99 }
 100
 101
 102 /* is_context_format is the same as "type2context" except that it just performs checking */
 103 /* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
 104
 105 VOID
 106 is_context_format(t)
 107   ttype t;
 108 {
 109     char *tycon_name;
 110     list  rest_args;
 111     ttype first_arg;
 112
 113     switch (tttype(t))
 114       {
 115         case tname :
 116           tycon_name = gtypeid(t);
 117
 118           /* just a class name ":: C =>" */
 119           if (tlist(gtypel(t)) == lnil)
 120             hsperror("is_context_format: variable missing after class name");
 121
 122           /* should be just: ":: C a =>" */
 123           else
 124             {
 125               first_arg = (ttype) lhd(gtypel(t));
 126               rest_args = ltl(gtypel(t)); /* should be nil */
 127               if (tlist(rest_args) != lnil)
 128                 hsperror ("is_context_format: too many variables after class name");
 129
 130               switch (tttype(first_arg))
 131                 {
 132                   case namedtvar:       /* ToDo: right? */
 133                     /* everything is cool; will fall off the end */
 134                     break;
 135                   default:
 136                     hsperror ("is_context_format: something wrong with variable after class name");
 137                 }
 138             }
 139           break;
 140
 141         case ttuple:
 142           hsperror ("is_context_format: tuple found in a context");
 143
 144         case namedtvar:
 145           hsperror ("is_context_format: unexpected namedtvar found in a context");
 146
 147         case tllist:
 148           hsperror ("is_context_format: list constructor found in a context");
 149
 150         case tfun:
 151           hsperror ("is_context_format: arrow (->) constructor found in a context");
 152
 153         case context:
 154           hsperror ("is_context_format: unexpected context-thing found in a context");
 155
 156         default:
 157             hsperror ("is_context_format: totally unexpected input");
 158       }
 159 }
 160