ghc/interpreter/derive.c

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