2 /* --------------------------------------------------------------------------
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
9 * $RCSfile: derive.c,v $
11 * $Date: 1999/03/09 14:51:06 $
12 * ------------------------------------------------------------------------*/
19 #include "Assembler.h"
26 static Cell varCompAux; /* auxiliary function for compares */
27 static Cell varCompare;
31 static Cell varRangeSize; /* calculate size of index range */
32 static Cell varInRange;
38 static Cell qvarMinus;
42 static Cell varToEnum;
43 static Cell varFromEnum;
44 static Cell varEnumFromTo;
45 static Cell varEnumFromThenTo;
48 static Cell varMinBound;
49 static Cell varMaxBound;
53 static Cell varShowField; /* display single field */
54 static Cell varShowParen; /* wrap with parens */
55 static Cell varCompose; /* function composition */
56 static Cell varShowsPrec;
60 static Cell varReadField; /* read single field */
61 static Cell varReadParen; /* unwrap from parens */
62 static Cell varLex; /* lexer */
63 static Cell varReadsPrec;
66 #if DERIVE_SHOW || DERIVE_READ
67 static Cell varAppend; /* list append */
69 #if DERIVE_EQ || DERIVE_IX
70 static Cell varAnd; /* built-in logical connectives */
72 #if DERIVE_EQ || DERIVE_ORD
77 List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
79 /* --------------------------------------------------------------------------
80 * local function prototypes:
81 * ------------------------------------------------------------------------*/
83 static List local getDiVars Args((Int));
84 static Cell local mkBind Args((String,List));
85 static Cell local mkVarAlts Args((Int,Cell));
87 #if DERIVE_EQ || DERIVE_ORD
88 static List local makeDPats2 Args((Cell,Int));
90 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
91 static Bool local isEnumType Args((Tycon));
94 static Pair local mkAltEq Args((Int,List));
95 static Pair local mkAltOrd Args((Int,List));
96 static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
97 static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
98 static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
99 static List local mkIxBinds Args((Int,Cell,Int));
100 static Cell local mkAltShow Args((Int,Cell,Int));
101 static Cell local showsPrecRhs Args((Cell,Cell,Int));
102 static Cell local mkReadCon Args((Name,Cell,Cell));
103 static Cell local mkReadPrefix Args((Cell));
104 static Cell local mkReadInfix Args((Cell));
105 static Cell local mkReadTuple Args((Cell));
106 static Cell local mkReadRecord Args((Cell,List));
107 static List local mkBndBinds Args((Int,Cell,Int));
111 /* --------------------------------------------------------------------------
113 * ------------------------------------------------------------------------*/
115 List diVars = NIL; /* Acts as a cache of invented vars*/
118 static List local getDiVars(n) /* get list of at least n vars for */
119 Int n; { /* derived instance generation */
120 for (; diNum<n; diNum++) {
121 diVars = cons(inventVar(),diVars);
126 static Cell local mkBind(s,alts) /* make a binding for a variable */
129 return pair(mkVar(findText(s)),pair(NIL,alts));
132 static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
133 Int line; /* a simple expression */
135 return singleton(pair(NIL,pair(mkInt(line),r)));
138 #if DERIVE_EQ || DERIVE_ORD
139 static List local makeDPats2(h,n) /* generate pattern list */
140 Cell h; /* by putting two new patterns with*/
141 Int n; { /* head h and new var components */
142 List us = getDiVars(2*n);
147 for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
153 for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
161 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
162 static Bool local isEnumType(t) /* Determine whether t is an enumeration */
163 Tycon t; { /* type (i.e. all constructors arity == 0) */
164 if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
165 List cs = tycon(t).defn;
166 for (; hasCfun(cs); cs=tl(cs)) {
167 if (name(hd(cs)).arity!=0) {
171 /* ToDo: correct? addCfunTable(t); */
178 /* --------------------------------------------------------------------------
179 * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
180 * The derived definitions of equality and ordering are given by:
182 * A a b == A x y = a==x && b==y
187 * compare (A a b) (A x y) = primCompAux a x (compare b y)
188 * compare (B a) (B x) = compare a x
190 * compare a x = cmpConstr a x
192 * In each case, the last line is only needed if there are multiple
193 * constructors in the datatype definition.
194 * ------------------------------------------------------------------------*/
198 static Pair local mkAltEq Args((Int,List));
200 List deriveEq(t) /* generate binding for derived == */
201 Type t; { /* for some TUPLE or DATATYPE t */
203 if (isTycon(t)) { /* deal with type constrs */
204 List cs = tycon(t).defn;
205 for (; hasCfun(cs); cs=tl(cs)) {
206 alts = cons(mkAltEq(tycon(t).line,
207 makeDPats2(hd(cs),userArity(hd(cs)))),
210 if (cfunOf(hd(tycon(t).defn))!=0) {
211 alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
212 pair(mkInt(tycon(t).line),nameFalse)),alts);
215 } else { /* special case for tuples */
216 alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
218 return singleton(mkBind("==",alts));
221 static Pair local mkAltEq(line,pats) /* make alt for an equation for == */
222 Int line; /* using patterns in pats for lhs */
223 List pats; { /* arguments */
225 Cell q = hd(tl(pats));
229 e = ap2(nameEq,arg(p),arg(q));
230 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
231 e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
234 return pair(pats,pair(mkInt(line),e));
236 #endif /* DERIVE_EQ */
240 static Pair local mkAltOrd Args((Int,List));
242 List deriveOrd(t) /* make binding for derived compare*/
243 Type t; { /* for some TUPLE or DATATYPE t */
245 if (isEnumType(t)) { /* special case for enumerations */
246 Cell u = inventVar();
247 Cell w = inventVar();
249 if (cfunOf(hd(tycon(t).defn))!=0) {
250 implementConToTag(t);
251 rhs = ap2(nameCompare,
252 ap(tycon(t).conToTag,u),
253 ap(tycon(t).conToTag,w));
257 alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
258 } else if (isTycon(t)) { /* deal with type constrs */
259 List cs = tycon(t).defn;
260 for (; hasCfun(cs); cs=tl(cs)) {
261 alts = cons(mkAltOrd(tycon(t).line,
262 makeDPats2(hd(cs),userArity(hd(cs)))),
265 if (cfunOf(hd(tycon(t).defn))!=0) {
266 Cell u = inventVar();
267 Cell w = inventVar();
268 implementConToTag(t);
269 alts = cons(pair(doubleton(u,w),
270 pair(mkInt(tycon(t).line),
272 ap(tycon(t).conToTag,u),
273 ap(tycon(t).conToTag,w)))),
277 } else { /* special case for tuples */
278 alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
280 return singleton(mkBind("compare",alts));
283 static Pair local mkAltOrd(line,pats) /* make alt for eqn for compare */
284 Int line; /* using patterns in pats for lhs */
285 List pats; { /* arguments */
287 Cell q = hd(tl(pats));
291 e = ap2(nameCompare,arg(p),arg(q));
292 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
293 e = ap3(nameCompAux,arg(p),arg(q),e);
297 return pair(pats,pair(mkInt(line),e));
299 #endif /* DERIVE_ORD */
302 /* --------------------------------------------------------------------------
303 * Deriving Ix and Enum:
304 * ------------------------------------------------------------------------*/
307 List deriveEnum(t) /* Construct definition of enumeration */
309 Int l = tycon(t).line;
310 Cell x = inventVar();
311 Cell y = inventVar();
312 Cell first = hd(tycon(t).defn);
313 Cell last = tycon(t).defn;
315 if (!isEnumType(t)) {
316 ERRMSG(l) "Can only derive instances of Enum for enumeration types"
319 while (hasCfun(tl(last))) {
323 implementConToTag(t);
324 implementTagToCon(t);
325 return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
326 cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
327 cons(mkBind("enumFrom", singleton(pair(singleton(x),
329 ap2(nameFromTo,x,last))))),
330 /* default instance of enumFromTo is good */
331 cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
333 ap3(nameFromThenTo,x,y,
334 ap(COND,triple(ap2(nameLe,x,y),
336 /* default instance of enumFromThenTo is good */
339 #endif /* DERIVE_ENUM */
342 static List local mkIxBindsEnum Args((Tycon));
343 static List local mkIxBinds Args((Int,Cell,Int));
344 static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
345 static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
346 static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
348 List deriveIx(t) /* Construct definition of indexing */
350 if (isEnumType(t)) { /* Definitions for enumerations */
351 implementConToTag(t);
352 implementTagToCon(t);
353 return mkIxBindsEnum(t);
354 } else if (isTuple(t)) { /* Definitions for product types */
355 return mkIxBinds(0,t,tupleOf(t));
356 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
357 return mkIxBinds(tycon(t).line,
359 userArity(hd(tycon(t).defn)));
361 ERRMSG(tycon(t).line)
362 "Can only derive instances of Ix for enumeration or product types"
364 return NIL;/* NOTREACHED*/
367 /* instance Ix T where
368 * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
370 * | inRange b ci = conToTag ci - conToTag c1
371 * | otherwise = error "Ix.index.T: Index out of range."
372 * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
373 * where i = conToTag ci
375 static List local mkIxBindsEnum(t)
377 Int l = tycon(t).line;
378 Name tagToCon = tycon(t).tagToCon;
379 Name conToTag = tycon(t).conToTag;
380 Cell b = inventVar();
381 Cell c1 = inventVar();
382 Cell c2 = inventVar();
383 Cell ci = inventVar();
384 return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
385 c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon,
386 ap2(nameFromTo,ap(conToTag,c1),
387 ap(conToTag,c2))))))),
388 cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
389 ap2(mkTuple(2),c1,c2))),ci),
390 pair(mkInt(l),ap(COND,
391 triple(ap2(nameInRange,b,ci),
392 ap2(nameMinus,ap(conToTag,ci),
394 ap(nameError,mkStr(findText(
395 "Ix.index: Index out of range"))))))))),
396 cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
397 c1,c2),ci), pair(mkInt(l),ap2(nameAnd,
398 ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
399 ap2(nameLe,ap(conToTag,ci),
400 ap(conToTag,c2))))))),
401 /* ToDo: share conToTag ci */
405 static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
406 Int line; /* a product type */
409 List vs = getDiVars(3*n);
417 for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
418 ls = ap(ls,hd(vs)); /* of the datatype concerned */
419 us = ap(us,hd(vs=tl(vs)));
420 is = ap(is,hd(vs=tl(vs)));
422 pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
423 pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
425 return cons(prodRange(line,singleton(pr),ls,us,is),
426 cons(prodIndex(line,pats,ls,us,is),
427 cons(prodInRange(line,pats,ls,us,is),
431 static Cell local prodRange(line,pats,ls,us,is)
432 Int line; /* Make definition of range for a */
433 List pats; /* product type */
435 /* range :: (a,a) -> [a]
436 * range (X a b c, X p q r)
437 * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
441 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
442 e = cons(ap(FROMQUAL,pair(arg(is),
443 ap(nameRange,ap2(mkTuple(2),
447 e = ap(COMP,pair(is1,e));
448 e = singleton(pair(pats,pair(mkInt(line),e)));
449 return mkBind("range",e);
452 static Cell local prodIndex(line,pats,ls,us,is)
453 Int line; /* Make definition of index for a */
454 List pats; /* product type */
456 /* index :: (a,a) -> a -> Bool
457 * index (X a b c, X p q r) (X x y z)
458 * = index (c,r) z + rangeSize (c,r) * (
459 * index (b,q) y + rangeSize (b,q) * (
464 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
465 xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
467 for (e=hd(xs); nonNull(xs=tl(xs));) {
469 e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
471 e = singleton(pair(pats,pair(mkInt(line),e)));
472 return mkBind("index",e);
475 static Cell local prodInRange(line,pats,ls,us,is)
476 Int line; /* Make definition of inRange for a*/
477 List pats; /* product type */
479 /* inRange :: (a,a) -> a -> Bool
480 * inRange (X a b c, X p q r) (X x y z)
481 * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
483 Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
484 while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
486 ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
489 e = singleton(pair(pats,pair(mkInt(line),e)));
490 return mkBind("inRange",e);
492 #endif /* DERIVE_IX */
495 /* --------------------------------------------------------------------------
497 * ------------------------------------------------------------------------*/
499 List deriveShow(t) /* Construct definition of text conversion */
502 if (isTycon(t)) { /* deal with type constrs */
503 List cs = tycon(t).defn;
504 for (; hasCfun(cs); cs=tl(cs)) {
505 alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
509 } else { /* special case for tuples */
510 alts = singleton(mkAltShow(0,t,tupleOf(t)));
512 return singleton(mkBind("showsPrec",alts));
515 static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
519 List vs = getDiVars(a+1);
524 for (vs=tl(vs); i<a; i++) {
525 pat = ap(pat,hd(vs));
528 pats = cons(d,cons(pat,NIL));
529 return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
532 #define shows0 ap(nameShowsPrec,mkInt(0))
533 #define shows10 ap(nameShowsPrec,mkInt(10))
534 #define showsOP ap(nameComp,consChar('('))
535 #define showsOB ap(nameComp,consChar('{'))
536 #define showsCM ap(nameComp,consChar(','))
537 #define showsSP ap(nameComp,consChar(' '))
538 #define showsBQ ap(nameComp,consChar('`'))
539 #define showsCP consChar(')')
540 #define showsCB consChar('}')
542 static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
543 Cell d, pat; /* given pattern, pat */
545 Cell h = getHead(pat);
546 List cfs = cfunSfuns;
549 /* To display a tuple:
550 * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
551 * showChar ',' . showsPrec 0 b .
552 * showChar ',' . showsPrec 0 c .
553 * showChar ',' . showsPrec 0 d .
559 rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
562 return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
565 for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
568 /* To display a value using record syntax:
569 * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
570 * showField "x" e . showChar ',' .
571 * showField "y" f . showChar ',' .
572 * showField "z" g . showChar '}'
574 * = showString lab . showChar '=' . shows val
577 List vs = dupOnto(snd(hd(cfs)),NIL);
582 mkStr(textOf(hd(vs))),
588 rhs = ap(showsCM,rhs);
594 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
598 /* To display a nullary constructor:
599 * showsPrec d Foo = showString "Foo"
601 return ap(nameApp,mkStr(name(h).text));
603 Syntax s = syntaxOf(h);
604 if (a==2 && assocOf(s)!=APPLIC) {
605 /* For a binary constructor with prec p:
606 * showsPrec d (a :* b) = showParen (d > p)
607 * (showsPrec lp a . showChar ' ' .
608 * showsString s . showChar ' ' .
612 Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
613 Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
614 Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
615 if (defaultSyntax(name(h).text)==APPLIC) {
618 ap(nameApp,mkStr(name(h).text)),
621 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
625 ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
627 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
631 /* To display a non-nullary constructor with applicative syntax:
632 * showsPrec d (Foo x y) = showParen (d>=10)
633 * (showString "Foo" .
634 * showChar ' ' . showsPrec 10 x .
635 * showChar ' ' . showsPrec 10 y)
637 Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
638 for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
639 rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
641 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
642 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
657 /* --------------------------------------------------------------------------
659 * ------------------------------------------------------------------------*/
661 #define Tuple2(f,s) ap2(mkTuple(2),f,s)
662 #define Lex(r) ap(nameLex,r)
663 #define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
664 #define ReadsPrec(n,e) ap2(nameReadsPrec,n,e)
665 #define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
666 #define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
667 #define ReadField(f,s) ap2(nameReadField,f,s)
668 #define GT(l,r) ap2(nameGt,l,r)
669 #define Append(a,b) ap2(nameApp,a,b)
671 /* Construct the readsPrec function of the form:
673 * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
674 * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
676 * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
678 List deriveRead(t) /* construct definition of text reader */
682 Cell d = inventVar();
683 Cell r = inventVar();
684 List pat = cons(d,cons(r,NIL));
688 List cs = tycon(t).defn;
690 for (; hasCfun(cs); cs=tl(cs)) {
691 exps = cons(mkReadCon(hd(cs),d,r),exps);
693 /* reverse concatenate list of subexpressions */
695 for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
696 exp = ap2(nameApp,hd(exps),exp);
698 line = tycon(t).line;
701 exp = ap(mkReadTuple(t),r);
703 /* printExp(stdout,exp); putc('\n',stdout); */
704 alt = pair(pat,pair(mkInt(line),exp));
705 return singleton(mkBind("readsPrec",singleton(alt)));
708 /* Generate an expression of the form:
710 * readParen (d > p) <derived expression> r
712 * for a (non-tuple) constructor "con" of precedence "p".
715 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
721 Syntax s = syntaxOf(con);
722 List cfs = cfunSfuns;
723 for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
726 exp = mkReadRecord(con,snd(hd(cfs)));
727 return ReadParen(nameFalse, exp, r);
730 if (userArity(con)==2 && assocOf(s)!=APPLIC) {
731 exp = mkReadInfix(con);
734 exp = mkReadPrefix(con);
737 return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
740 /* Given an n-ary prefix constructor, generate a single lambda
741 * expression, such that
743 * data T ... = Constr a1 a2 .. an | ....
747 * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
748 * (t1,s1) <- readsPrec 10 s0,
749 * (t2,s2) <- readsPrec 10 s1,
751 * (tn,sn) <- readsPrec 10 sn-1 ]
754 static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
756 Int arity = userArity(con);
757 Cell cn = mkStr(name(con).text);
758 Cell r = inventVar();
759 Cell prev_s = inventVar();
764 /* build (reversed) list of qualifiers and constructor */
765 quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
766 for(i=0; i<arity; i++) {
767 Cell t = inventVar();
768 Cell s = inventVar();
769 quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
774 /* \r -> [ (exp, prev_s) | quals ] */
775 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
778 /* Given a binary infix constructor of precedence p
780 * ... | T1 `con` T2 | ...
782 * generate the lambda expression
784 * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
785 * ("con",s1) <- lex s0,
786 * (v,s2) <- readsPrec rp s1 ]
788 * where lp and rp are either p or p+1 depending on associativity
790 static Cell local mkReadInfix( con )
793 Syntax s = syntaxOf(con);
795 Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
796 Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
797 Cell cn = mkStr(name(con).text);
798 Cell r = inventVar();
799 Cell s0 = inventVar();
800 Cell s1 = inventVar();
801 Cell s2 = inventVar();
802 Cell u = inventVar();
803 Cell v = inventVar();
806 quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
807 quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
808 quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
810 return Lambda(singleton(r),
811 ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
814 /* Given the n-ary tuple constructor return a lambda expression:
816 * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
817 * (t1, s1) <- readsPrec 0 s0,
819 * (",",s(2n-1)) <- lex s(2n-2),
820 * (tn, s(2n)) <- readsPrec 0 s(2n-1),
821 * (")",s(2n+1)) <- lex s(2n) ]
823 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
825 Int arity = tupleOf(tup);
826 Cell lp = mkStr(findText("("));
827 Cell rp = mkStr(findText(")"));
828 Cell co = mkStr(findText(","));
830 Cell r = inventVar();
832 Cell s = inventVar();
837 /* build (reversed) list of qualifiers and constructor */
838 for(i=0; i<arity; i++) {
839 Cell t = inventVar();
840 Cell si = inventVar();
841 Cell sj = inventVar();
842 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
843 quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
848 quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
850 /* \ r -> [ (exp,s) | quals ] */
851 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
854 /* Given a record constructor
856 * ... | C { f1 :: T1, ... fn :: Tn } | ...
858 * generate the expression:
860 * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
861 * ("{", s1) <- lex s0,
862 * (t1, s2) <- readField "f1" s1,
864 * (",", s(2n-1)) <- lex s(2n),
865 * (tn, s(2n)) <- readField "fn" s(2n+1),
866 * ("}", s(2n+1)) <- lex s(2n+2) ]
870 * readField :: Read a => String -> ReadS a
871 * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
872 * ("=",s2) <- lex s1,
873 * r <- readsPrec 10 s2 ]
875 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
878 Cell cn = mkStr(name(con).text);
879 Cell lb = mkStr(findText("{"));
880 Cell rb = mkStr(findText("}"));
881 Cell co = mkStr(findText(","));
883 Cell r = inventVar();
884 Cell s0 = inventVar();
886 Cell s = inventVar();
890 /* build (reversed) list of qualifiers and constructor */
891 quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
892 for(; nonNull(fs); fs=tl(fs)) {
893 Cell f = mkStr(textOf(hd(fs)));
894 Cell t = inventVar();
895 Cell si = inventVar();
896 Cell sj = inventVar();
897 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
898 quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
903 quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
905 /* \ r -> [ (exp,s) | quals ] */
906 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
919 /* --------------------------------------------------------------------------
921 * ------------------------------------------------------------------------*/
925 List deriveBounded(t) /* construct definition of bounds */
928 Cell last = tycon(t).defn;
929 Cell first = hd(last);
930 while (hasCfun(tl(last))) {
933 return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
934 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
936 } else if (isTuple(t)) { /* Definitions for product types */
937 return mkBndBinds(0,t,tupleOf(t));
938 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
939 return mkBndBinds(tycon(t).line,
941 userArity(hd(tycon(t).defn)));
943 ERRMSG(tycon(t).line)
944 "Can only derive instances of Bounded for enumeration and product types"
949 static List local mkBndBinds(line,h,n) /* build bindings for derived */
950 Int line; /* Bounded on a product type */
956 minB = ap(minB,nameMinBnd);
957 maxB = ap(maxB,nameMaxBnd);
959 return cons(mkBind("minBound",mkVarAlts(line,minB)),
960 cons(mkBind("maxBound",mkVarAlts(line,maxB)),
963 #endif /* DERIVE_BOUNDED */
967 /* --------------------------------------------------------------------------
968 * Helpers: conToTag and tagToCon
969 * ------------------------------------------------------------------------*/
971 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
972 Void implementConToTag(t)
974 if (isNull(tycon(t).conToTag)) {
975 List cs = tycon(t).defn;
976 Name nm = newName(inventText(),NIL);
977 StgVar v = mkStgVar(NIL,NIL);
978 List alts = NIL; /* can't fail */
980 assert(isTycon(t) && (tycon(t).what==DATATYPE
981 || tycon(t).what==NEWTYPE));
982 for (; hasCfun(cs); cs=tl(cs)) {
984 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
985 StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
987 StgExpr tag = mkStgLet(singleton(r),r);
990 for(i=0; i < name(c).arity; ++i) {
991 vs = cons(mkStgVar(NIL,NIL),vs);
993 alts = cons(mkStgCaseAlt(c,vs,tag),alts);
996 name(nm).line = tycon(t).line;
997 name(nm).type = conToTagType(t);
999 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
1001 tycon(t).conToTag = nm;
1002 /* hack to make it print out */
1003 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
1007 /* \ v -> case v of { ...; i -> Ci; ... } */
1008 Void implementTagToCon(t)
1010 if (isNull(tycon(t).tagToCon)) {
1024 assert(nameUnpackString);
1026 assert(isTycon(t) && (tycon(t).what==DATATYPE
1027 || tycon(t).what==NEWTYPE));
1029 tyconname = textToStr(tycon(t).text);
1030 etxt = malloc(100+strlen(tyconname));
1033 "out-of-range arg for `toEnum' "
1034 "in derived `instance Enum %s'",
1038 nm = newName(inventText(),NIL);
1039 v1 = mkStgVar(NIL,NIL);
1040 v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
1042 txt0 = mkStr(findText(etxt));
1043 bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
1044 bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
1045 bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
1050 mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
1052 makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
1056 for (; hasCfun(cs); cs=tl(cs)) {
1058 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
1059 StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
1060 assert(name(c).arity==0);
1061 alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
1064 name(nm).line = tycon(t).line;
1065 name(nm).type = tagToConType(t);
1067 name(nm).stgVar = mkStgVar(
1076 mkStgPrimCase(v2,alts))))),
1079 tycon(t).tagToCon = nm;
1080 /* hack to make it print out */
1081 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
1082 if (etxt) free(etxt);
1087 /* --------------------------------------------------------------------------
1088 * Derivation control:
1089 * ------------------------------------------------------------------------*/
1091 Void deriveControl(what)
1093 Text textPrelude = findText("Prelude");
1097 varTrue = mkQVar(textPrelude,findText("True"));
1098 varFalse = mkQVar(textPrelude,findText("False"));
1100 varCompAux = mkQVar(textPrelude,findText("primCompAux"));
1101 varCompare = mkQVar(textPrelude,findText("compare"));
1102 varEQ = mkQVar(textPrelude,findText("EQ"));
1105 varRangeSize = mkQVar(textPrelude,findText("rangeSize"));
1106 varInRange = mkQVar(textPrelude,findText("inRange"));
1107 varRange = mkQVar(textPrelude,findText("range"));
1108 varIndex = mkQVar(textPrelude,findText("index"));
1109 varMult = mkQVar(textPrelude,findText("*"));
1110 qvarPlus = mkQVar(textPrelude,findText("+"));
1111 varMap = mkQVar(textPrelude,findText("map"));
1112 qvarMinus = mkQVar(textPrelude,findText("-"));
1113 varError = mkQVar(textPrelude,findText("error"));
1116 varToEnum = mkQVar(textPrelude,findText("toEnum"));
1117 varFromEnum = mkQVar(textPrelude,findText("fromEnum"));
1118 varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
1119 varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
1122 varMinBound = mkQVar(textPrelude,findText("minBound"));
1123 varMaxBound = mkQVar(textPrelude,findText("maxBound"));
1126 conCons = mkQCon(textPrelude,findText(":"));
1127 varShowField = mkQVar(textPrelude,findText("primShowField"));
1128 varShowParen = mkQVar(textPrelude,findText("showParen"));
1129 varCompose = mkQVar(textPrelude,findText("."));
1130 varShowsPrec = mkQVar(textPrelude,findText("showsPrec"));
1131 varLe = mkQVar(textPrelude,findText("<="));
1134 varReadField = mkQVar(textPrelude,findText("primReadField"));
1135 varReadParen = mkQVar(textPrelude,findText("readParen"));
1136 varLex = mkQVar(textPrelude,findText("lex"));
1137 varReadsPrec = mkQVar(textPrelude,findText("readsPrec"));
1138 varGt = mkQVar(textPrelude,findText(">"));
1140 #if DERIVE_SHOW || DERIVE_READ
1141 varAppend = mkQVar(textPrelude,findText("++"));
1143 #if DERIVE_EQ || DERIVE_IX
1144 varAnd = mkQVar(textPrelude,findText("&&"));
1146 #if DERIVE_EQ || DERIVE_ORD
1147 varEq = mkQVar(textPrelude,findText("=="));
1150 /* deliberate fall through */
1154 #if DERIVE_SHOW | DERIVE_READ
1161 #if DERIVE_SHOW | DERIVE_READ
1186 mark(varEnumFromTo);
1187 mark(varEnumFromThenTo);
1208 #if DERIVE_SHOW || DERIVE_READ
1211 #if DERIVE_EQ || DERIVE_IX
1214 #if DERIVE_EQ || DERIVE_ORD
1222 /*-------------------------------------------------------------------------*/