ghc/interpreter/derive.c

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