ghc/interpreter/kind.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * Part of type checker dealing with kind inference
   4  *
   5  * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
   6  * All rights reserved. See NOTICE for details and conditions of use etc...
   7  * Hugs version 1.4, December 1997
   8  *
   9  * $RCSfile: kind.c,v $
  10  * $Revision: 1.2 $
  11  * $Date: 1998/12/02 13:22:16 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #define newKindvars(n)  newTyvars(n)    /* to highlight uses of type vars  */
  15                                         /* as kind variables               */
  16
  17 Bool kindExpert = FALSE;                /* TRUE => display kind errors in  */
  18                                         /*         full detail             */
  19
  20 /* --------------------------------------------------------------------------
  21  * Kind checking code:
  22  * ------------------------------------------------------------------------*/
  23
  24 static Void local kindError(l,c,in,wh,k,o)
  25 Int    l;                               /* line number near constuctor exp */
  26 Constr c;                               /* constructor                     */
  27 Constr in;                              /* context (if any)                */
  28 String wh;                              /* place in which error occurs     */
  29 Kind   k;                               /* expected kind (k,o)             */
  30 Int    o; {                             /* inferred kind (typeIs,typeOff)  */
  31     clearMarks();
  32
  33     if (!kindExpert) {                  /* for those with a fear of kinds  */
  34         ERRMSG(l) "Illegal type" ETHEN
  35         if (nonNull(in)) {
  36             ERRTEXT " \"" ETHEN ERRTYPE(in);
  37             ERRTEXT "\""  ETHEN
  38         }
  39         ERRTEXT " in %s\n", wh
  40         EEND;
  41     }
  42
  43     ERRMSG(l) "Kind error in %s", wh ETHEN
  44     if (nonNull(in)) {
  45         ERRTEXT "\n*** expression     : " ETHEN ERRTYPE(in);
  46     }
  47     ERRTEXT "\n*** constructor    : " ETHEN ERRTYPE(c);
  48     ERRTEXT "\n*** kind           : " ETHEN ERRKIND(copyType(typeIs,typeOff));
  49     ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
  50     if (unifyFails) {
  51         ERRTEXT "\n*** because        : %s", unifyFails ETHEN
  52     }
  53     ERRTEXT "\n"
  54     EEND;
  55 }
  56
  57 #define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
  58                                       kindError(l,c,in,wh,k,o)
  59 #define checkKind(l,c,in,wh,k,o)  kindConstr(l,c); shouldKind(l,c,in,wh,k,o)
  60 #define inferKind(k,o)            typeIs=k; typeOff=o
  61
  62 static Int  locCVars;                   /* offset to local variable kinds  */
  63 static List unkindTypes;                /* types in need of kind annotation*/
  64 #if TREX
  65 static Kind extKind;                    /* Kind of extension, *->row->row  */
  66 #endif
  67
  68 static Void local kindConstr(l,c)       /* Determine kind of constructor   */
  69 Int  l;
  70 Cell c; {
  71     Cell h = getHead(c);
  72     Int  n = argCount;
  73
  74     if (isSynonym(h) && n<tycon(h).arity) {
  75         ERRMSG(l) "Not enough arguments for type synonym \"%s\"",
  76                   textToStr(tycon(h).text)
  77         EEND;
  78     }
  79
  80 #if TREX
  81     if (isExt(h) && n!=2) {
  82         ERRMSG(l) "Illegal use of row in " ETHEN ERRTYPE(c);
  83         ERRTEXT "\n"
  84         EEND;
  85     }
  86 #endif
  87
  88     if (n==0)                           /* trivial case, no arguments      */
  89         typeIs = kindAtom(c);
  90     else {                              /* non-trivial application         */
  91         static String app = "constructor application";
  92         Cell   a = c;
  93         Int    i;
  94         Kind   k;
  95         Int    beta;
  96
  97         varKind(n);
  98         beta   = typeOff;
  99         k      = typeIs;
 100
 101         typeIs = kindAtom(h);           /* h  :: v1 -> ... -> vn -> w      */
 102         shouldKind(l,h,c,app,k,beta);
 103
 104         for (i=n; i>0; --i) {           /* ci :: vi for each 1 <- 1..n     */
 105             checkKind(l,arg(a),c,app,var,beta+i-1);
 106             a = fun(a);
 107         }
 108         tyvarType(beta+n);              /* inferred kind is w              */
 109     }
 110 }
 111
 112 static Kind local kindAtom(c)           /* Find kind of atomic constructor */
 113 Cell c; {
 114     switch (whatIs(c)) {
 115         case TUPLE  : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
 116         case OFFSET : return mkInt(locCVars+offsetOf(c));
 117         case TYCON  : return tycon(c).kind;
 118 #if TREX
 119         case EXT    : return extKind;
 120 #endif
 121     }
 122     internal("kindAtom");
 123     return STAR;/* not reached */
 124 }
 125
 126 static Void local kindPred(line,pred)   /* Check kinds of arguments in pred*/
 127 Int  line;
 128 Cell pred; {
 129     static String predicate = "class constraint";
 130 #if TREX
 131     if (isExt(fun(pred))) {
 132         checkKind(line,arg(pred),NIL,predicate,ROW,0);
 133         return;
 134     }
 135 #endif
 136     checkKind(line,arg(pred),NIL,predicate,cclass(fun(pred)).sig,0);
 137 }
 138
 139 static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
 140 Int    line;                            /* is well-kinded                  */
 141 String wh;
 142 Type   type; {
 143     locCVars = 0;
 144     if (isPolyType(type)) {             /* local constructor vars reqd?    */
 145         Kind k      = polySigOf(type);
 146         Int  n      = 0;
 147         for (; isPair(k); k=snd(k))
 148             n++;
 149         locCVars    = newKindvars(n);
 150         unkindTypes = cons(pair(mkInt(locCVars),snd(type)),unkindTypes);
 151         type        = monoTypeOf(type);
 152     }
 153     if (whatIs(type)==QUAL) {           /* examine context (if any)        */
 154         map1Proc(kindPred,line,fst(snd(type)));
 155         type = snd(snd(type));
 156     }
 157     checkKind(line,type,NIL,wh,STAR,0); /* finally, check type part        */
 158 }
 159
 160 static Void local fixKinds() {          /* add kind annotations to types   */
 161     for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
 162         Pair pr   = hd(unkindTypes);
 163         Int  beta = intOf(fst(pr));
 164         Cell qts  = fst(snd(pr));
 165         for (;;) {
 166             if (isNull(hd(qts)))
 167                 hd(qts) = copyKindvar(beta++);
 168             else
 169                 hd(qts) = ap(hd(qts),copyKindvar(beta++));
 170             if (nonNull(tl(qts)))
 171                 qts = tl(qts);
 172             else {
 173                 tl(qts) = STAR;
 174                 break;
 175             }
 176         }
 177 #ifdef DEBUG_KINDS
 178         Printf("Type expression: ");
 179         printType(stdout,snd(snd(pr)));
 180         Printf(" :: ");
 181         printKind(stdout,fst(snd(pr)));
 182         Printf("\n");
 183 #endif
 184     }
 185 }
 186
 187 /* --------------------------------------------------------------------------
 188  * Kind checking of groups of type constructors and classes:
 189  * ------------------------------------------------------------------------*/
 190
 191 Void kindTCGroup(tcs)                   /* find kinds for mutually rec. gp */
 192 List tcs; {                             /* of tycons and classes           */
 193     typeChecker(RESET);
 194     mapProc(initTCKind,tcs);
 195     mapProc(kindTC,tcs);
 196     mapProc(genTC,tcs);
 197     fixKinds();
 198     typeChecker(RESET);
 199 }
 200
 201 static Void local initTCKind(c)         /* build initial kind/arity for c  */
 202 Cell c; {
 203     if (isTycon(c)) {                   /* Initial kind of tycon is:       */
 204         Int beta = newKindvars(1);      /*    v1 -> ... -> vn -> vn+1      */
 205         varKind(tycon(c).arity);        /* where n is the arity of c.      */
 206         bindTv(beta,typeIs,typeOff);    /* For data definitions, vn+1 == * */
 207         switch (whatIs(tycon(c).what)) {
 208             case NEWTYPE  :
 209             case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
 210         }
 211         tycon(c).kind = mkInt(beta);
 212     }
 213     else
 214         cclass(c).sig = mkInt(newKindvars(1));
 215 }
 216
 217 static Void local kindTC(c)             /* check each part of a tycon/class*/
 218 Cell c; {                               /* is well-kinded                  */
 219     if (isTycon(c)) {
 220         static String cfun = "constructor function";
 221         static String tsyn = "synonym definition";
 222         Int line = tycon(c).line;
 223
 224         locCVars = tyvar(intOf(tycon(c).kind))->offs;
 225         switch (whatIs(tycon(c).what)) {
 226             case NEWTYPE     :
 227             case DATATYPE    : {   List cs = tycon(c).defn;
 228                                    if (whatIs(cs)==QUAL) {
 229                                        map1Proc(kindPred,line,fst(snd(cs)));
 230                                        tycon(c).defn = cs = snd(snd(cs));
 231                                    }
 232                                    for (; hasCfun(cs); cs=tl(cs))
 233                                        kindType(line,cfun,name(hd(cs)).type);
 234                                    break;
 235                                }
 236
 237             default          : checkKind(line,tycon(c).defn,NIL,
 238                                            tsyn,var,locCVars+tycon(c).arity);
 239         }
 240     }
 241     else {                              /* scan type exprs in class defn to*/
 242         List ms  = cclass(c).members;   /* determine the class signature   */
 243         List scs = cclass(c).supers;
 244
 245         for (; nonNull(scs); scs=tl(scs))
 246             if (!kunify(cclass(hd(scs)).sig,0,cclass(c).sig,0)) {
 247                 ERRMSG(cclass(c).line)
 248                     "Kind of class \"%s\" does not match superclass \"%s\"",
 249                     textToStr(cclass(c).text), textToStr(cclass(hd(scs)).text)
 250                 EEND;
 251             }
 252
 253         for (; nonNull(ms); ms=tl(ms)) {
 254             Int  line = intOf(fst3(hd(ms)));
 255             Type type = thd3(hd(ms));
 256             kindType(line,"member function type signature",type);
 257         }
 258     }
 259 }
 260
 261 static Void local genTC(c)              /* generalise kind inferred for    */
 262 Cell c; {                               /* given tycon/class               */
 263     if (isTycon(c)) {
 264         tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
 265 #ifdef DEBUG_KINDS
 266         Printf("%s :: ",textToStr(tycon(c).text));
 267         printKind(stdout,tycon(c).kind);
 268         Putchar('\n');
 269 #endif
 270     }
 271     else {
 272         cclass(c).sig = copyKindvar(intOf(cclass(c).sig));
 273 #ifdef DEBUG_KINDS
 274         Printf("%s :: ",textToStr(cclass(c).text));
 275         printKind(stdout,cclass(c).sig);
 276         Putchar('\n');
 277 #endif
 278     }
 279 }
 280
 281 static Kind local copyKindvar(vn)       /* build kind attatched to variable*/
 282 Int vn; {
 283     Tyvar *tyv = tyvar(vn);
 284     if (tyv->bound)
 285         return copyKind(tyv->bound,tyv->offs);
 286     return STAR;                        /* any unbound variable defaults to*/
 287 }                                       /* the kind of all types           */
 288
 289 static Kind local copyKind(k,o)         /* build kind expression from      */
 290 Kind k;                                 /* given skeleton                  */
 291 Int  o; {
 292     switch (whatIs(k)) {
 293         case AP      : {   Kind l = copyKind(fst(k),o);  /* ensure correct */
 294                            Kind r = copyKind(snd(k),o);  /* eval. order    */
 295                            return ap(l,r);
 296                        }
 297         case OFFSET  : return copyKindvar(o+offsetOf(k));
 298         case INTCELL : return copyKindvar(intOf(k));
 299     }
 300     return k;
 301 }
 302
 303 /* --------------------------------------------------------------------------
 304  * Kind checking of instance declaration headers:
 305  * ------------------------------------------------------------------------*/
 306
 307 Void kindInst(in,h)                     /* check predicates in instance    */
 308 Inst in;
 309 Cell h; {
 310     typeChecker(RESET);
 311     locCVars = newKindvars(inst(in).arity);
 312     kindPred(inst(in).line,h);
 313     map1Proc(kindPred,inst(in).line,inst(in).specifics);
 314     typeChecker(RESET);
 315 }
 316
 317 /* --------------------------------------------------------------------------
 318  * Kind checking of individual type signatures:
 319  * ------------------------------------------------------------------------*/
 320
 321 Void kindSigType(line,type)             /* check that type is well-kinded  */
 322 Int  line;
 323 Type type; {
 324     typeChecker(RESET);
 325     kindType(line,"type expression",type);
 326     fixKinds();
 327     typeChecker(RESET);
 328 }
 329
 330 /* --------------------------------------------------------------------------
 331  * Kind checking of default types:
 332  * ------------------------------------------------------------------------*/
 333
 334 Void kindDefaults(line,ts)              /* check that list of types are    */
 335 Int  line;                              /* well-kinded                     */
 336 List ts; {
 337     typeChecker(RESET);
 338     map2Proc(kindType,line,"default type",ts);
 339     fixKinds();
 340     typeChecker(RESET);
 341 }
 342
 343 /* --------------------------------------------------------------------------
 344  * Support for `kind preserving substitutions' from unification:
 345  * ------------------------------------------------------------------------*/
 346
 347 static Bool local eqKind(k1,k2)         /* check that two (mono)kinds are  */
 348 Kind k1, k2; {                          /* equal                           */
 349     return k1==k2
 350            || (isPair(k1) && isPair(k2)
 351               && eqKind(fst(k1),fst(k2))
 352               && eqKind(snd(k1),snd(k2)));
 353 }
 354
 355 static Kind local getKind(c,o)          /* Find kind of constr during type */
 356 Cell c;                                 /* checking process                */
 357 Int  o; {
 358     if (isAp(c))                                     /* application        */
 359         return snd(getKind(fst(c),o));
 360     switch (whatIs(c)) {
 361         case TUPLE  : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */
 362         case OFFSET : return tyvar(o+offsetOf(c))->kind;
 363         case INTCELL: return tyvar(intOf(c))->kind;
 364         case TYCON  : return tycon(c).kind;
 365 #if TREX
 366         case EXT    : return extKind;
 367 #endif
 368     }
 369 #ifdef DEBUG_KINDS
 370     Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
 371 #endif
 372     internal("getKind");
 373     return STAR;/* not reached */
 374 }
 375
 376 /* --------------------------------------------------------------------------
 377  * Two forms of kind expression are used quite frequently:
 378  *      *  -> *  -> ... -> *  -> *      for kinds of ->, [], ->, (,) etc...
 379  *      v1 -> v2 -> ... -> vn -> vn+1   skeletons for constructor kinds
 380  * Expressions of these forms are produced by the following functions which
 381  * use a cache to avoid repeated construction of commonly used values.
 382  * A similar approach is used to store the types of tuple constructors in the
 383  * main type checker.
 384  * ------------------------------------------------------------------------*/
 385
 386 #define MAXKINDFUN 10
 387 static  Kind simpleKindCache[MAXKINDFUN];
 388 static  Kind varKindCache[MAXKINDFUN];
 389
 390 static Kind local makeSimpleKind(n)     /* construct * -> ... -> * (n args)*/
 391 Int n; {
 392     Kind k = STAR;
 393     while (n-- > 0)
 394         k = ap(STAR,k);
 395     return k;
 396 }
 397
 398 static Kind local simpleKind(n)         /* return (possibly cached) simple */
 399 Int n; {                                /* function kind                   */
 400     if (n>=MAXKINDFUN)
 401         return makeSimpleKind(n);
 402     else if (nonNull(simpleKindCache[n]))
 403         return simpleKindCache[n];
 404     else if (n==0)
 405         return simpleKindCache[0] = STAR;
 406     else
 407         return simpleKindCache[n] = ap(STAR,simpleKind(n-1));
 408 }
 409
 410 static Kind local makeVarKind(n)        /* construct v0 -> .. -> vn        */
 411 Int n; {
 412     Kind k = mkOffset(n);
 413     while (n-- > 0)
 414         k = ap(mkOffset(n),k);
 415     return k;
 416 }
 417
 418 static Void local varKind(n)            /* return (possibly cached) var    */
 419 Int n; {                                /* function kind                   */
 420     typeOff = newKindvars(n+1);
 421     if (n>=MAXKINDFUN)
 422         typeIs = makeVarKind(n);
 423     else if (nonNull(varKindCache[n]))
 424         typeIs = varKindCache[n];
 425     else
 426         typeIs = varKindCache[n] = makeVarKind(n);
 427 }
 428
 429 /*-------------------------------------------------------------------------*/