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