ghc/compiler/parser/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 static void is_context_format PROTO((ttype, int)); /* forward */
  16
  17 /*
  18     partain: see also the comment by "decl" in hsparser.y.
  19
  20     Here, we've been given a type that must be of the form
  21     "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
  22
  23     Convert it to a list.
  24 */
  25
  26
  27 list
  28 type2context(t)
  29   ttype t;
  30 {
  31     list  args;
  32
  33     switch (tttype(t)) {
  34       case ttuple:
  35         /* returning the list is OK, but ensure items are right format */
  36         args = gttuple(t);
  37
  38         if (tlist(args) == lnil)
  39           hsperror ("type2context: () found instead of a context");
  40
  41         while (tlist(args) != lnil)
  42           {
  43             is_context_format(lhd(args), 0);
  44             args = ltl(args);
  45           }
  46
  47         return(gttuple(t)); /* args */
  48
  49
  50       case tapp:
  51       case tname:
  52         /* a single item, ensure correct format */
  53         is_context_format(t, 0);
  54         return(lsing(t));
  55
  56       case namedtvar:
  57         hsperror ("type2context: unexpected namedtvar found in a context");
  58
  59       case tllist:
  60         hsperror ("type2context: list constructor found in a context");
  61
  62       case tfun:
  63         hsperror ("type2context: arrow (->) constructor found in a context");
  64
  65       case context:
  66         hsperror ("type2context: unexpected context-thing found in a context");
  67
  68       default:
  69         hsperror ("type2context: totally unexpected input");
  70     }
  71     abort(); /* should never get here! */
  72 }
  73
  74
  75 /* is_context_format is the same as "type2context" except that it just performs checking */
  76 /* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
  77
  78 static void
  79 is_context_format(t, tyvars)
  80   ttype t;
  81   int tyvars;
  82 {
  83     list  rest_args;
  84     ttype first_arg;
  85
  86     switch (tttype(t))
  87       {
  88         case tname :
  89           /* should be just: ":: C a =>" */
  90
  91           if (tyvars == 0)
  92             hsperror("is_context_format: variable missing after class name");
  93
  94           else if (tyvars > 1)
  95             hsperror ("is_context_format: too many variables after class name");
  96
  97           /* tyvars == 1; everything is cool */
  98           break;
  99
 100         case tapp:
 101           if (tttype(gtarg(t)) != namedtvar)
 102               hsperror ("is_context_format: something wrong with variable after class name");
 103
 104           is_context_format(gtapp(t), tyvars+1);
 105           break;
 106
 107         case ttuple:
 108           hsperror ("is_context_format: tuple found in a context");
 109
 110         case namedtvar:
 111           hsperror ("is_context_format: unexpected namedtvar found in a context");
 112
 113         case tllist:
 114           hsperror ("is_context_format: list constructor found in a context");
 115
 116         case tfun:
 117           hsperror ("is_context_format: arrow (->) constructor found in a context");
 118
 119         case context:
 120           hsperror ("is_context_format: unexpected context-thing found in a context");
 121
 122         default:
 123             hsperror ("is_context_format: totally unexpected input");
 124       }
 125 }
 126