ghc/interpreter/derive.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Deriving
   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: derive.c,v $
  10  * $Revision: 1.3 $
  11  * $Date: 1999/02/03 17:08:27 $
  12  * ------------------------------------------------------------------------*/
  13
  14 #include "prelude.h"
  15 #include "storage.h"
  16 #include "backend.h"
  17 #include "connect.h"
  18 #include "errors.h"
  19
  20 static Cell varTrue;
  21 static Cell varFalse;
  22 #if DERIVE_ORD
  23 static Cell varCompAux;                /* auxiliary function for compares */
  24 static Cell varCompare;
  25 static Cell varEQ;
  26 #endif
  27 #if DERIVE_IX
  28 static Cell varRangeSize;              /* calculate size of index range   */
  29 static Cell varInRange;
  30 static Cell varRange;
  31 static Cell varIndex;
  32 static Cell varMult;
  33 static Cell varPlus;
  34 static Cell varMap;
  35 static Cell varMinus;
  36 static Cell varError;
  37 #endif
  38 #if DERIVE_ENUM
  39 static Cell varToEnum;
  40 static Cell varFromEnum;
  41 static Cell varEnumFromTo;
  42 static Cell varEnumFromThenTo;
  43 #endif
  44 #if DERIVE_BOUNDED
  45 static Cell varMinBound;
  46 static Cell varMaxBound;
  47 #endif
  48 #if DERIVE_SHOW
  49        Cell conCons;
  50 static Cell varShowField;              /* display single field            */
  51 static Cell varShowParen;              /* wrap with parens                */
  52 static Cell varCompose;                /* function composition            */
  53 static Cell varShowsPrec;
  54 static Cell varLe;
  55 #endif
  56 #if DERIVE_READ
  57 static Cell varReadField;              /* read single field               */
  58 static Cell varReadParen;              /* unwrap from parens              */
  59 static Cell varLex;                    /* lexer                           */
  60 static Cell varReadsPrec;
  61 static Cell varGt;
  62 #endif
  63 #if DERIVE_SHOW || DERIVE_READ
  64 static Cell varAppend;                 /* list append                     */
  65 List cfunSfuns;                        /* List of (Cfun,[SelectorVar])    */
  66 #endif
  67 #if DERIVE_EQ || DERIVE_IX
  68 static Cell varAnd;                    /* built-in logical connectives    */
  69 #endif
  70 #if DERIVE_EQ || DERIVE_ORD
  71 static Cell varEq;
  72 #endif
  73
  74
  75 /* --------------------------------------------------------------------------
  76  * local function prototypes:
  77  * ------------------------------------------------------------------------*/
  78
  79 static List  local getDiVars            Args((Int));
  80 static Cell  local mkBind               Args((String,List));
  81 static Cell  local mkVarAlts            Args((Int,Cell));
  82
  83 #if DERIVE_EQ || DERIVE_ORD
  84 static List  local makeDPats2           Args((Cell,Int));
  85 #endif
  86 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
  87 static Bool  local isEnumType           Args((Tycon));
  88 #endif
  89
  90 static Pair   local mkAltEq             Args((Int,List));
  91 static Pair   local mkAltOrd            Args((Int,List));
  92 static Cell   local prodRange           Args((Int,List,Cell,Cell,Cell));
  93 static Cell   local prodIndex           Args((Int,List,Cell,Cell,Cell));
  94 static Cell   local prodInRange         Args((Int,List,Cell,Cell,Cell));
  95 static List   local mkIxBinds           Args((Int,Cell,Int));
  96 static Cell   local mkAltShow           Args((Int,Cell,Int));
  97 static Cell   local showsPrecRhs        Args((Cell,Cell,Int));
  98 static Cell   local mkReadCon           Args((Name,Cell,Cell));
  99 static Cell   local mkReadPrefix        Args((Cell));
 100 static Cell   local mkReadInfix         Args((Cell));
 101 static Cell   local mkReadTuple         Args((Cell));
 102 static Cell   local mkReadRecord        Args((Cell,List));
 103 static List   local mkBndBinds          Args((Int,Cell,Int));
 104
 105
 106
 107 /* --------------------------------------------------------------------------
 108  * Deriving Utilities
 109  * ------------------------------------------------------------------------*/
 110
 111 List diVars = NIL;                      /* Acts as a cache of invented vars*/
 112 Int  diNum  = 0;
 113
 114 static List local getDiVars(n)          /* get list of at least n vars for */
 115 Int n; {                                /* derived instance generation     */
 116     for (; diNum<n; diNum++) {
 117         diVars = cons(inventVar(),diVars);
 118     }
 119     return diVars;
 120 }
 121
 122 static Cell local mkBind(s,alts)        /* make a binding for a variable   */
 123 String s;
 124 List   alts; {
 125     return pair(mkVar(findText(s)),pair(NIL,alts));
 126 }
 127
 128 static Cell local mkVarAlts(line,r)     /* make alts for binding a var to  */
 129 Int  line;                              /* a simple expression             */
 130 Cell r; {
 131     return singleton(pair(NIL,pair(mkInt(line),r)));
 132 }
 133
 134 /* --------------------------------------------------------------------------
 135  * Given a datatype:   data T a b = A a b | B Int | C  deriving (Eq, Ord)
 136  * The derived definitions of equality and ordering are given by:
 137  *
 138  *   A a b == A x y  =  a==x && b==y
 139  *   B a   == B x    =  a==x
 140  *   C     == C      =  True
 141  *   _     == _      =  False
 142  *
 143  *   compare (A a b) (A x y) =  primCompAux a x (compare b y)
 144  *   compare (B a)   (B x)   =  compare a x
 145  *   compare C       C       =  EQ
 146  *   compare a       x       =  cmpConstr a x
 147  *
 148  * In each case, the last line is only needed if there are multiple
 149  * constructors in the datatype definition.
 150  * ------------------------------------------------------------------------*/
 151
 152 #define ap2(f,x,y) ap(ap(f,x),y)
 153
 154 List local deriveEq(t)                  /* generate binding for derived == */
 155 Type t; {                               /* for some TUPLE or DATATYPE t    */
 156     List alts = NIL;
 157     if (isTycon(t)) {                   /* deal with type constrs          */
 158         List cs = tycon(t).defn;
 159         for (; hasCfun(cs); cs=tl(cs)) {
 160             alts = cons(mkAltEq(tycon(t).line,
 161                                 makeDPats2(hd(cs),userArity(hd(cs)))),
 162                         alts);
 163         }
 164         if (cfunOf(hd(tycon(t).defn))!=0) {
 165             alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
 166                              pair(mkInt(tycon(t).line),nameFalse)),alts);
 167         }
 168         alts = rev(alts);
 169     }
 170     else {                              /* special case for tuples         */
 171         alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
 172     }
 173     return singleton(mkBind("==",alts));
 174 }
 175
 176 static Pair local mkAltEq(line,pats)    /* make alt for an equation for == */
 177 Int  line;                              /* using patterns in pats for lhs  */
 178 List pats; {                            /* arguments                       */
 179     Cell p = hd(pats);
 180     Cell q = hd(tl(pats));
 181     Cell e = nameTrue;
 182
 183     if (isAp(p)) {
 184         e = ap2(nameEq,arg(p),arg(q));
 185         for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
 186             e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
 187         }
 188     }
 189     return pair(pats,pair(mkInt(line),e));
 190 }
 191
 192 List deriveOrd(t)                       /* make binding for derived compare*/
 193 Type t; {                               /* for some TUPLE or DATATYPE t    */
 194     List alts = NIL;
 195     if (isEnumType(t)) {                /* special case for enumerations   */
 196         alts = mkVarAlts(tycon(t).line,nameConCmp);
 197     } else if (isTycon(t)) {            /* deal with type constrs          */
 198         List cs = tycon(t).defn;
 199         for (; hasCfun(cs); cs=tl(cs)) {
 200             alts = cons(mkAltOrd(tycon(t).line,
 201                                  makeDPats2(hd(cs),userArity(hd(cs)))),
 202                         alts);
 203         }
 204         if (cfunOf(hd(tycon(t).defn))!=0) {
 205             Cell u = inventVar();
 206             Cell w = inventVar();
 207             alts   = cons(pair(cons(u,singleton(w)),
 208                                pair(mkInt(tycon(t).line),
 209                                     ap2(nameConCmp,u,w))),alts);
 210         }
 211         alts = rev(alts);
 212     } else {                            /* special case for tuples         */
 213         alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
 214     }
 215     return singleton(mkBind("compare",alts));
 216 }
 217
 218 static Pair local mkAltOrd(line,pats)   /* make alt for eqn for compare    */
 219 Int  line;                              /* using patterns in pats for lhs  */
 220 List pats; {                            /* arguments                       */
 221     Cell p = hd(pats);
 222     Cell q = hd(tl(pats));
 223     Cell e = nameEQ;
 224
 225     if (isAp(p)) {
 226         e = ap2(nameCompare,arg(p),arg(q));
 227         for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
 228             e = ap(ap2(nameCompAux,arg(p),arg(q)),e);
 229         }
 230     }
 231
 232     return pair(pats,pair(mkInt(line),e));
 233 }
 234
 235 static List local makeDPats2(h,n)       /* generate pattern list           */
 236 Cell h;                                 /* by putting two new patterns with*/
 237 Int  n; {                               /* head h and new var components   */
 238     List us = getDiVars(2*n);
 239     List vs = NIL;
 240     Cell p;
 241     Int  i;
 242
 243     for (i=0, p=h; i<n; ++i) {          /* make first version of pattern   */
 244         p  = ap(p,hd(us));
 245         us = tl(us);
 246     }
 247     vs = cons(p,vs);
 248
 249     for (i=0, p=h; i<n; ++i) {          /* make second version of pattern  */
 250         p  = ap(p,hd(us));
 251         us = tl(us);
 252     }
 253     return cons(p,vs);
 254 }
 255
 256 /* --------------------------------------------------------------------------
 257  * Deriving Ix and Enum:
 258  * ------------------------------------------------------------------------*/
 259
 260 List deriveEnum(t)              /* Construct definition of enumeration     */
 261 Tycon t; {
 262     Int l = tycon(t).line;
 263
 264     if (!isEnumType(t)) {
 265         ERRMSG(l) "Can only derive instances of Enum for enumeration types"
 266         EEND;
 267     }
 268
 269     return cons(mkBind("toEnum",mkVarAlts(l,ap(nameEnToEn,hd(tycon(t).defn)))),
 270             cons(mkBind("fromEnum",mkVarAlts(l,nameEnFrEn)),
 271              cons(mkBind("enumFrom",mkVarAlts(l,nameEnFrom)),
 272               cons(mkBind("enumFromTo",mkVarAlts(l,nameEnFrTo)),
 273                cons(mkBind("enumFromThen",mkVarAlts(l,nameEnFrTh)),NIL)))));
 274 }
 275
 276 List deriveIx(t)                /* Construct definition of indexing        */
 277 Tycon t; {
 278     if (isEnumType(t)) {        /* Definitions for enumerations            */
 279         return cons(mkBind("range",mkVarAlts(tycon(t).line,nameEnRange)),
 280                 cons(mkBind("index",mkVarAlts(tycon(t).line,nameEnIndex)),
 281                  cons(mkBind("inRange",mkVarAlts(tycon(t).line,nameEnInRng)),
 282                   NIL)));
 283     } else if (isTuple(t)) {    /* Definitions for product types           */
 284         return mkIxBinds(0,t,tupleOf(t));
 285     } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
 286         return mkIxBinds(tycon(t).line,
 287                          hd(tycon(t).defn),
 288                          userArity(hd(tycon(t).defn)));
 289     }
 290     ERRMSG(tycon(t).line)
 291         "Can only derive instances of Ix for enumeration or product types"
 292     EEND;
 293     return NIL;/* NOTREACHED*/
 294 }
 295
 296 static Bool local isEnumType(t) /* Determine whether t is an enumeration   */
 297 Tycon t; {                      /* type (i.e. all constructors arity == 0) */
 298     if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
 299         List cs = tycon(t).defn;
 300         for (; hasCfun(cs); cs=tl(cs)) {
 301             if (name(hd(cs)).arity!=0) {
 302                 return FALSE;
 303             }
 304         }
 305         /* ToDo: correct?  addCfunTable(t); */
 306         return TRUE;
 307     }
 308     return FALSE;
 309 }
 310
 311 static List local mkIxBinds(line,h,n)   /* build bindings for derived Ix on*/
 312 Int  line;                              /* a product type                  */
 313 Cell h;
 314 Int  n; {
 315     List vs   = getDiVars(3*n);
 316     Cell ls   = h;
 317     Cell us   = h;
 318     Cell is   = h;
 319     Cell pr   = NIL;
 320     Cell pats = NIL;
 321     Int  i;
 322
 323     for (i=0; i<n; ++i, vs=tl(vs)) {    /* build three patterns for values */
 324         ls = ap(ls,hd(vs));             /* of the datatype concerned       */
 325         us = ap(us,hd(vs=tl(vs)));
 326         is = ap(is,hd(vs=tl(vs)));
 327     }
 328     pr   = ap2(mkTuple(2),ls,us);       /* Build (ls,us)                   */
 329     pats = cons(pr,cons(is,NIL));       /* Build [(ls,us),is]              */
 330
 331     return cons(prodRange(line,singleton(pr),ls,us,is),
 332                 cons(prodIndex(line,pats,ls,us,is),
 333                      cons(prodInRange(line,pats,ls,us,is),NIL)));
 334 }
 335
 336 static Cell local prodRange(line,pats,ls,us,is)
 337 Int  line;                              /* Make definition of range for a  */
 338 List pats;                              /* product type                    */
 339 Cell ls, us, is; {
 340     /* range :: (a,a) -> [a]
 341      * range (X a b c, X p q r)
 342      *   = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
 343      */
 344     Cell is1 = is;
 345     List e   = NIL;
 346     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
 347         e = cons(ap(FROMQUAL,pair(arg(is),
 348                                   ap(nameRange,ap2(mkTuple(2),
 349                                                    arg(ls),
 350                                                    arg(us))))),e);
 351     }
 352     e = ap(COMP,pair(is1,e));
 353     e = singleton(pair(pats,pair(mkInt(line),e)));
 354     return mkBind("range",e);
 355 }
 356
 357 static Cell local prodIndex(line,pats,ls,us,is)
 358 Int  line;                              /* Make definition of index for a  */
 359 List pats;                              /* product type                    */
 360 Cell ls, us, is; {
 361     /* index :: (a,a) -> a -> Bool
 362      * index (X a b c, X p q r) (X x y z)
 363      *  = index (c,r) z + rangeSize (c,r) * (
 364      *     index (b,q) y + rangeSize (b,q) * (
 365      *      index (a,x) x))
 366      */
 367     List xs = NIL;
 368     Cell e  = NIL;
 369     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
 370         xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
 371     }
 372     for (e=hd(xs); nonNull(xs=tl(xs));) {
 373         Cell x = hd(xs);
 374         e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
 375     }
 376     e = singleton(pair(pats,pair(mkInt(line),e)));
 377     return mkBind("index",e);
 378 }
 379
 380 static Cell local prodInRange(line,pats,ls,us,is)
 381 Int  line;                              /* Make definition of inRange for a*/
 382 List pats;                              /* product type                    */
 383 Cell ls, us, is; {
 384     /* inRange :: (a,a) -> a -> Bool
 385      * inRange (X a b c, X p q r) (X x y z)
 386      *          = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
 387      */
 388     Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
 389     while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
 390         e = ap2(nameAnd,
 391                 ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
 392                 e);
 393     }
 394     e = singleton(pair(pats,pair(mkInt(line),e)));
 395     return mkBind("inRange",e);
 396 }
 397
 398 /* --------------------------------------------------------------------------
 399  * Deriving Show:
 400  * ------------------------------------------------------------------------*/
 401
 402 List deriveShow(t)              /* Construct definition of text conversion */
 403 Tycon t; {
 404     List alts = NIL;
 405     if (isTycon(t)) {                   /* deal with type constrs          */
 406         List cs = tycon(t).defn;
 407         for (; hasCfun(cs); cs=tl(cs)) {
 408             alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
 409                         alts);
 410         }
 411         alts = rev(alts);
 412     } else {                            /* special case for tuples         */
 413         alts = singleton(mkAltShow(0,t,tupleOf(t)));
 414     }
 415     return singleton(mkBind("showsPrec",alts));
 416 }
 417
 418 static Cell local mkAltShow(line,h,a)   /* make alt for showsPrec eqn      */
 419 Int  line;
 420 Cell h;
 421 Int  a; {
 422     List vs   = getDiVars(a+1);
 423     Cell d    = hd(vs);
 424     Cell pat  = h;
 425     List pats = NIL;
 426     Int  i    = 0;
 427     for (vs=tl(vs); i<a; i++) {
 428         pat = ap(pat,hd(vs));
 429         vs  = tl(vs);
 430     }
 431     pats = cons(d,cons(pat,NIL));
 432     return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
 433 }
 434
 435 #define shows0   ap(nameShowsPrec,mkInt(0))
 436 #define shows10  ap(nameShowsPrec,mkInt(10))
 437 #define showsOP  ap(nameComp,consChar('('))
 438 #define showsOB  ap(nameComp,consChar('{'))
 439 #define showsCM  ap(nameComp,consChar(','))
 440 #define showsSP  ap(nameComp,consChar(' '))
 441 #define showsBQ  ap(nameComp,consChar('`'))
 442 #define showsCP  consChar(')')
 443 #define showsCB  consChar('}')
 444
 445 static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
 446 Cell d, pat;                            /* given pattern, pat              */
 447 Int  a; {
 448     Cell h   = getHead(pat);
 449     List cfs = cfunSfuns;
 450
 451     if (isTuple(h)) {
 452         /* To display a tuple:
 453          *    showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
 454          *                            showChar ',' . showsPrec 0 b .
 455          *                            showChar ',' . showsPrec 0 c .
 456          *                            showChar ',' . showsPrec 0 d .
 457          *                            showChar ')'
 458          */
 459         Int  i   = tupleOf(h);
 460         Cell rhs = showsCP;
 461         for (; i>1; --i) {
 462             rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
 463             pat = fun(pat);
 464         }
 465         return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
 466     }
 467
 468     for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
 469     }
 470     if (nonNull(cfs)) {
 471         /* To display a value using record syntax:
 472          *    showsPrec d C{x=e, y=f, z=g} = showString "C"  . showChar '{' .
 473          *                                   showField "x" e . showChar ',' .
 474          *                                   showField "y" f . showChar ',' .
 475          *                                   showField "z" g . showChar '}'
 476          *    showField lab val
 477          *      = showString lab . showChar '=' . shows val
 478          */
 479         Cell rhs     = showsCB;
 480         List vs      = dupOnto(snd(hd(cfs)),NIL);
 481         if (isAp(pat)) {
 482             for (;;) {
 483                 rhs = ap2(nameComp,
 484                           ap2(nameShowField,
 485                               mkStr(textOf(hd(vs))),
 486                               arg(pat)),
 487                           rhs);
 488                 pat = fun(pat);
 489                 vs  = tl(vs);
 490                 if (isAp(pat)) {
 491                     rhs = ap(showsCM,rhs);
 492                 } else {
 493                     break;
 494                 }
 495             }
 496         }
 497         rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
 498         return rhs;
 499     }
 500     else if (a==0) {
 501         /* To display a nullary constructor:
 502          *    showsPrec d Foo = showString "Foo"
 503          */
 504         return ap(nameApp,mkStr(name(h).text));
 505     } else {
 506         Syntax s = syntaxOf(h);
 507         if (a==2 && assocOf(s)!=APPLIC) {
 508             /* For a binary constructor with prec p:
 509              * showsPrec d (a :* b) = showParen (d > p)
 510              *                          (showsPrec lp a . showChar ' ' .
 511              *                           showsString s  . showChar ' ' .
 512              *                           showsPrec rp b)
 513              */
 514             Int  p   = precOf(s);
 515             Int  lp  = (assocOf(s)==LEFT_ASS)  ? p : (p+1);
 516             Int  rp  = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
 517             Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
 518             if (defaultSyntax(name(h).text)==APPLIC) {
 519                 rhs = ap(showsBQ,
 520                          ap2(nameComp,
 521                              ap(nameApp,mkStr(name(h).text)),
 522                              ap(showsBQ,rhs)));
 523             } else {
 524                 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
 525             }
 526
 527             rhs = ap2(nameComp,
 528                       ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
 529                       ap(showsSP,rhs));
 530             rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
 531             return rhs;
 532         }
 533         else {
 534             /* To display a non-nullary constructor with applicative syntax:
 535              *    showsPrec d (Foo x y) = showParen (d>=10)
 536              *                             (showString "Foo" .
 537              *                              showChar ' ' . showsPrec 10 x .
 538              *                              showChar ' ' . showsPrec 10 y)
 539              */
 540             Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
 541             for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
 542                 rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
 543             }
 544             rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
 545             rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
 546             return rhs;
 547         }
 548     }
 549 }
 550 #undef  shows10
 551 #undef  shows0
 552 #undef  showsOP
 553 #undef  showsOB
 554 #undef  showsCM
 555 #undef  showsSP
 556 #undef  showsBQ
 557 #undef  showsCP
 558 #undef  showsCB
 559
 560 /* --------------------------------------------------------------------------
 561  * Deriving Read:
 562  * ------------------------------------------------------------------------*/
 563
 564 #define Tuple2(f,s)      ap2(mkTuple(2),f,s)
 565 #define Lex(r)           ap(nameLex,r)
 566 #define ZFexp(h,q)       ap(FROMQUAL, pair(h,q))
 567 #define ReadsPrec(n,e)   ap2(nameReadsPrec,n,e)
 568 #define Lambda(v,e)      ap(LAMBDA,pair(v, pair(mkInt(0),e)))
 569 #define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
 570 #define ReadField(f,s)   ap2(nameReadField,f,s)
 571 #define GT(l,r)          ap2(nameGt,l,r)
 572 #define Append(a,b)      ap2(nameApp,a,b)
 573
 574 /*  Construct the readsPrec function of the form:
 575  *
 576  *    readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
 577  *                    (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
 578  *                    ...
 579  *                    (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
 580  */
 581 List deriveRead(t)              /* construct definition of text reader     */
 582 Cell t; {
 583     Cell alt  = NIL;
 584     Cell exp  = NIL;
 585     Cell d    = inventVar();
 586     Cell r    = inventVar();
 587     List pat  = cons(d,cons(r,NIL));
 588     Int  line = 0;
 589
 590     if (isTycon(t)) {
 591         List cs = tycon(t).defn;
 592         List exps = NIL;
 593         for (; hasCfun(cs); cs=tl(cs)) {
 594             exps = cons(mkReadCon(hd(cs),d,r),exps);
 595         }
 596         /* reverse concatenate list of subexpressions */
 597         exp = hd(exps);
 598         for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
 599             exp = ap2(nameApp,hd(exps),exp);
 600         }
 601         line = tycon(t).line;
 602     }
 603     else { /* Tuples */
 604         exp = ap(mkReadTuple(t),r);
 605     }
 606     /* printExp(stdout,exp); putc('\n',stdout); */
 607     alt  = pair(pat,pair(mkInt(line),exp));
 608     return singleton(mkBind("readsPrec",singleton(alt)));
 609 }
 610
 611 /* Generate an expression of the form:
 612  *
 613  *   readParen (d > p) <derived expression> r
 614  *
 615  * for a (non-tuple) constructor "con" of precedence "p".
 616  */
 617
 618 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
 619 Name con;
 620 Cell d;
 621 Cell r; {
 622     Cell exp = NIL;
 623     Int  p   = 0;
 624     Syntax s = syntaxOf(con);
 625     List cfs = cfunSfuns;
 626     for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
 627     }
 628     if (nonNull(cfs)) {
 629         exp = mkReadRecord(con,snd(hd(cfs)));
 630         return ReadParen(nameFalse, exp, r);
 631     }
 632
 633     if (userArity(con)==2 && assocOf(s)!=APPLIC) {
 634         exp = mkReadInfix(con);
 635         p   = precOf(s);
 636     } else {
 637         exp = mkReadPrefix(con);
 638         p   = 9;
 639     }
 640     return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
 641 }
 642
 643 /* Given an n-ary prefix constructor, generate a single lambda
 644  * expression, such that
 645  *
 646  *   data T ... = Constr a1 a2 .. an | ....
 647  *
 648  * derives
 649  *
 650  *   \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
 651  *                                        (t1,s1) <- readsPrec 10 s0,
 652  *                                        (t2,s2) <- readsPrec 10 s1,
 653  *                                        ...,
 654  *                                        (tn,sn) <- readsPrec 10 sn-1 ]
 655  *
 656  */
 657 static Cell local mkReadPrefix(con)    /* readsPrec for prefix constructor */
 658 Cell con; {
 659     Int  arity  = userArity(con);
 660     Cell cn     = mkStr(name(con).text);
 661     Cell r      = inventVar();
 662     Cell prev_s = inventVar();
 663     Cell exp    = con;
 664     List quals  = NIL;
 665     Int  i;
 666
 667     /* build (reversed) list of qualifiers and constructor */
 668     quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
 669     for(i=0; i<arity; i++) {
 670         Cell t = inventVar();
 671         Cell s = inventVar();
 672         quals  = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
 673         exp    = ap(exp,t);
 674         prev_s = s;
 675     }
 676
 677     /* \r -> [ (exp, prev_s) | quals ] */
 678     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
 679 }
 680
 681 /* Given a binary infix constructor of precedence p
 682  *
 683  *   ... | T1 `con` T2 | ...
 684  *
 685  * generate the lambda expression
 686  *
 687  *   \ r -> [ (u `con` v, s2) | (u,s0)     <- readsPrec lp r,
 688  *                              ("con",s1) <- lex s0,
 689  *                              (v,s2)     <- readsPrec rp s1 ]
 690  *
 691  * where lp and rp are either p or p+1 depending on associativity
 692  */
 693 static Cell local mkReadInfix( con )
 694 Cell con;
 695 {
 696     Syntax s  = syntaxOf(con);
 697     Int    p  = precOf(s);
 698     Int    lp = assocOf(s)==LEFT_ASS  ? p : (p+1);
 699     Int    rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
 700     Cell   cn = mkStr(name(con).text);
 701     Cell   r  = inventVar();
 702     Cell   s0 = inventVar();
 703     Cell   s1 = inventVar();
 704     Cell   s2 = inventVar();
 705     Cell   u  = inventVar();
 706     Cell   v  = inventVar();
 707     List quals = NIL;
 708
 709     quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)),  quals);
 710     quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)),                 quals);
 711     quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
 712
 713     return Lambda(singleton(r),
 714                   ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
 715 }
 716
 717 /* Given the n-ary tuple constructor return a lambda expression:
 718  *
 719  *   \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0)      <- lex r,
 720  *                                      (t1, s1)      <- readsPrec 0 s0,
 721  *                                      ...
 722  *                                      (",",s(2n-1)) <- lex s(2n-2),
 723  *                                      (tn, s(2n))   <- readsPrec 0 s(2n-1),
 724  *                                      (")",s(2n+1)) <- lex s(2n) ]
 725  */
 726 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
 727 Cell tup; {
 728     Int  arity  = tupleOf(tup);
 729     Cell lp     = mkStr(findText("("));
 730     Cell rp     = mkStr(findText(")"));
 731     Cell co     = mkStr(findText(","));
 732     Cell sep    = lp;
 733     Cell r      = inventVar();
 734     Cell prev_s = r;
 735     Cell s      = inventVar();
 736     Cell exp    = tup;
 737     List quals  = NIL;
 738     Int  i;
 739
 740     /* build (reversed) list of qualifiers and constructor */
 741     for(i=0; i<arity; i++) {
 742         Cell t  = inventVar();
 743         Cell si = inventVar();
 744         Cell sj = inventVar();
 745         quals  = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
 746         quals  = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
 747         exp    = ap(exp,t);
 748         prev_s = sj;
 749         sep    = co;
 750     }
 751     quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
 752
 753     /* \ r -> [ (exp,s) | quals ] */
 754     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
 755 }
 756
 757 /* Given a record constructor
 758  *
 759  *   ... | C { f1 :: T1, ... fn :: Tn } | ...
 760  *
 761  * generate the expression:
 762  *
 763  *   \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0)    <- lex r,
 764  *                                      ("{", s1)    <- lex s0,
 765  *                                      (t1,  s2)    <- readField "f1" s1,
 766  *                                      ...
 767  *                                      (",", s(2n-1)) <- lex s(2n),
 768  *                                      (tn,  s(2n)) <- readField "fn" s(2n+1),
 769  *                                      ("}", s(2n+1)) <- lex s(2n+2) ]
 770  *
 771  * where
 772  *
 773  *   readField    :: Read a => String -> ReadS a
 774  *   readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
 775  *                          ("=",s2) <- lex s1,
 776  *                          r        <- readsPrec 10 s2 ]
 777  */
 778 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
 779 Cell con;
 780 List fs; {
 781     Cell cn     = mkStr(name(con).text);
 782     Cell lb     = mkStr(findText("{"));
 783     Cell rb     = mkStr(findText("}"));
 784     Cell co     = mkStr(findText(","));
 785     Cell sep    = lb;
 786     Cell r      = inventVar();
 787     Cell s0     = inventVar();
 788     Cell prev_s = s0;
 789     Cell s      = inventVar();
 790     Cell exp    = con;
 791     List quals  = NIL;
 792
 793     /* build (reversed) list of qualifiers and constructor */
 794     quals  = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
 795     for(; nonNull(fs); fs=tl(fs)) {
 796         Cell f  = mkStr(textOf(hd(fs)));
 797         Cell t  = inventVar();
 798         Cell si = inventVar();
 799         Cell sj = inventVar();
 800         quals  = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),     quals);
 801         quals  = cons(ZFexp(Tuple2(t,  sj),ReadField(f,si)), quals);
 802         exp    = ap(exp,t);
 803         prev_s = sj;
 804         sep    = co;
 805     }
 806     quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
 807
 808     /* \ r -> [ (exp,s) | quals ] */
 809     return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
 810 }
 811
 812 #undef Tuple2
 813 #undef Lex
 814 #undef ZFexp
 815 #undef ReadsPrec
 816 #undef Lambda
 817 #undef ReadParen
 818 #undef ReadField
 819 #undef GT
 820 #undef Append
 821
 822 /* --------------------------------------------------------------------------
 823  * Deriving Bounded:
 824  * ------------------------------------------------------------------------*/
 825
 826 #if DERIVE_BOUNDED
 827
 828 List deriveBounded(t)             /* construct definition of bounds        */
 829 Tycon t; {
 830     if (isEnumType(t)) {
 831         Cell last  = tycon(t).defn;
 832         Cell first = hd(last);
 833         while (hasCfun(tl(last))) {
 834             last = tl(last);
 835         }
 836         return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
 837                 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
 838                  NIL));
 839     } else if (isTuple(t)) {    /* Definitions for product types           */
 840         return mkBndBinds(0,t,tupleOf(t));
 841     } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
 842         return mkBndBinds(tycon(t).line,
 843                           hd(tycon(t).defn),
 844                           userArity(hd(tycon(t).defn)));
 845     }
 846     ERRMSG(tycon(t).line)
 847      "Can only derive instances of Bounded for enumeration and product types"
 848     EEND;
 849     return NIL;
 850 }
 851
 852 static List local mkBndBinds(line,h,n)  /* build bindings for derived      */
 853 Int  line;                              /* Bounded on a product type       */
 854 Cell h;
 855 Int  n; {
 856     Cell minB = h;
 857     Cell maxB = h;
 858     while (n-- > 0) {
 859         minB = ap(minB,nameMinBnd);
 860         maxB = ap(maxB,nameMaxBnd);
 861     }
 862     return cons(mkBind("minBound",mkVarAlts(line,minB)),
 863             cons(mkBind("maxBound",mkVarAlts(line,maxB)),
 864              NIL));
 865 }
 866 #endif /* DERIVE_BOUNDED */
 867
 868
 869 /* --------------------------------------------------------------------------
 870  * Derivation control:
 871  * ------------------------------------------------------------------------*/
 872
 873 Void deriveControl(what)
 874 Int what; {
 875     Text textPrelude = findText("PreludeBuiltin");
 876     switch (what) {
 877         case INSTALL :
 878                 varTrue           = mkQVar(textPrelude,findText("True"));
 879                 varFalse          = mkQVar(textPrelude,findText("False"));
 880 #if DERIVE_ORD
 881                 varCompAux        = mkQVar(textPrelude,findText("primCompAux"));
 882                 varCompare        = mkQVar(textPrelude,findText("compare"));
 883                 varEQ             = mkQVar(textPrelude,findText("EQ"));
 884 #endif
 885 #if DERIVE_IX
 886                 varRangeSize      = mkQVar(textPrelude,findText("rangeSize"));
 887                 varInRange        = mkQVar(textPrelude,findText("inRange"));
 888                 varRange          = mkQVar(textPrelude,findText("range"));
 889                 varIndex          = mkQVar(textPrelude,findText("index"));
 890                 varMult           = mkQVar(textPrelude,findText("*"));
 891                 varPlus           = mkQVar(textPrelude,findText("+"));
 892                 varMap            = mkQVar(textPrelude,findText("map"));
 893                 varMinus          = mkQVar(textPrelude,findText("-"));
 894                 varError          = mkQVar(textPrelude,findText("error"));
 895 #endif
 896 #if DERIVE_ENUM
 897                 varToEnum         = mkQVar(textPrelude,findText("toEnum"));
 898                 varFromEnum       = mkQVar(textPrelude,findText("fromEnum"));
 899                 varEnumFromTo     = mkQVar(textPrelude,findText("enumFromTo"));
 900                 varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
 901 #endif
 902 #if DERIVE_BOUNDED
 903                 varMinBound       = mkQVar(textPrelude,findText("minBound"));
 904                 varMaxBound       = mkQVar(textPrelude,findText("maxBound"));
 905 #endif
 906 #if DERIVE_SHOW
 907                 conCons           = mkQCon(textPrelude,findText(":"));
 908                 varShowField      = mkQVar(textPrelude,findText("primShowField"));
 909                 varShowParen      = mkQVar(textPrelude,findText("showParen"));
 910                 varCompose        = mkQVar(textPrelude,findText("."));
 911                 varShowsPrec      = mkQVar(textPrelude,findText("showsPrec"));
 912                 varLe             = mkQVar(textPrelude,findText("<="));
 913 #endif
 914 #if DERIVE_READ
 915                 varReadField      = mkQVar(textPrelude,findText("primReadField"));
 916                 varReadParen      = mkQVar(textPrelude,findText("readParen"));
 917                 varLex            = mkQVar(textPrelude,findText("lex"));
 918                 varReadsPrec      = mkQVar(textPrelude,findText("readsPrec"));
 919                 varGt             = mkQVar(textPrelude,findText(">"));
 920 #endif
 921 #if DERIVE_SHOW || DERIVE_READ
 922                 varAppend         = mkQVar(textPrelude,findText("++"));
 923 #endif
 924 #if DERIVE_EQ || DERIVE_IX
 925                 varAnd            = mkQVar(textPrelude,findText("&&"));
 926 #endif
 927 #if DERIVE_EQ || DERIVE_ORD
 928                 varEq             = mkQVar(textPrelude,findText("=="));
 929 #endif
 930                 /* deliberate fall through */
 931         case RESET   :
 932                 diVars      = NIL;
 933                 diNum       = 0;
 934 #if DERIVE_SHOW | DERIVE_READ
 935                 cfunSfuns   = NIL;
 936 #endif
 937                 break;
 938
 939         case MARK    :
 940                 mark(diVars);
 941 #if DERIVE_SHOW | DERIVE_READ
 942                 mark(cfunSfuns);
 943 #endif
 944                 mark(varTrue);
 945                 mark(varFalse);
 946 #if DERIVE_ORD
 947                 mark(varCompAux);
 948                 mark(varCompare);
 949                 mark(varEQ);
 950 #endif
 951 #if DERIVE_IX
 952                 mark(varRangeSize);
 953                 mark(varInRange);
 954                 mark(varRange);
 955                 mark(varIndex);
 956                 mark(varMult);
 957                 mark(varPlus);
 958                 mark(varMap);
 959                 mark(varMinus);
 960                 mark(varError);
 961 #endif
 962 #if DERIVE_ENUM
 963                 mark(varToEnum);
 964                 mark(varFromEnum);
 965                 mark(varEnumFromTo);
 966                 mark(varEnumFromThenTo);
 967 #endif
 968 #if DERIVE_BOUNDED
 969                 mark(varMinBound);
 970                 mark(varMaxBound);
 971 #endif
 972 #if DERIVE_SHOW
 973                 mark(conCons);
 974                 mark(varShowField);
 975                 mark(varShowParen);
 976                 mark(varCompose);
 977                 mark(varShowsPrec);
 978                 mark(varLe);
 979 #endif
 980 #if DERIVE_READ
 981                 mark(varReadField);
 982                 mark(varReadParen);
 983                 mark(varLex);
 984                 mark(varReadsPrec);
 985                 mark(varGt);
 986 #endif
 987 #if DERIVE_SHOW || DERIVE_READ
 988                 mark(varAppend);
 989 #endif
 990 #if DERIVE_EQ || DERIVE_IX
 991                 mark(varAnd);
 992 #endif
 993 #if DERIVE_EQ || DERIVE_ORD
 994                 mark(varEq);
 995 #endif
 996                 break;
 997     }
 998 }
 999
1000 /*-------------------------------------------------------------------------*/