1 /* -*- mode: hugs-c; -*- */
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: 1998/12/02 13:22:03 $
12 * ------------------------------------------------------------------------*/
18 #include "translate.h" /* for implementConTag */
24 static Cell varCompAux; /* auxiliary function for compares */
25 static Cell varCompare;
29 static Cell varRangeSize; /* calculate size of index range */
30 static Cell varInRange;
40 static Cell varToEnum;
41 static Cell varFromEnum;
42 static Cell varEnumFromTo;
43 static Cell varEnumFromThenTo;
46 static Cell varMinBound;
47 static Cell varMaxBound;
51 static Cell varShowField; /* display single field */
52 static Cell varShowParen; /* wrap with parens */
53 static Cell varCompose; /* function composition */
54 static Cell varShowsPrec;
58 static Cell varReadField; /* read single field */
59 static Cell varReadParen; /* unwrap from parens */
60 static Cell varLex; /* lexer */
61 static Cell varReadsPrec;
64 #if DERIVE_SHOW || DERIVE_READ
65 static Cell varAppend; /* list append */
66 List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
68 #if DERIVE_EQ || DERIVE_IX
69 static Cell varAnd; /* built-in logical connectives */
71 #if DERIVE_EQ || DERIVE_ORD
76 /* --------------------------------------------------------------------------
77 * local function prototypes:
78 * ------------------------------------------------------------------------*/
80 static List local getDiVars Args((Int));
81 static Cell local mkBind Args((String,List));
82 static Cell local mkVarAlts Args((Int,Cell));
84 #if DERIVE_EQ || DERIVE_ORD
85 static List local makeDPats2 Args((Cell,Int));
87 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
88 static Bool local isEnumType Args((Tycon));
91 /* --------------------------------------------------------------------------
93 * ------------------------------------------------------------------------*/
95 static List diVars = NIL; /* Acts as a cache of invented vars*/
98 static List local getDiVars(n) /* get list of at least n vars for */
99 Int n; { /* derived instance generation */
100 for (; diNum<n; diNum++) {
101 diVars = cons(inventVar(),diVars);
106 static Cell local mkBind(s,alts) /* make a binding for a variable */
109 return pair(mkVar(findText(s)),pair(NIL,alts));
112 static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
113 Int line; /* a simple expression */
115 return singleton(pair(NIL,pair(mkInt(line),r)));
118 #if DERIVE_EQ || DERIVE_ORD
119 static List local makeDPats2(h,n) /* generate pattern list */
120 Cell h; /* by putting two new patterns with*/
121 Int n; { /* head h and new var components */
122 List us = getDiVars(2*n);
127 for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
133 for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
141 #if DERIVE_ORD || DERIVE_ENUM || DERIVE_IX || DERIVE_BOUNDED
142 static Bool local isEnumType(t) /* Determine whether t is an enumeration */
143 Tycon t; { /* type (i.e. all constructors arity == 0) */
144 if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
145 List cs = tycon(t).defn;
146 for (; hasCfun(cs); cs=tl(cs)) {
147 if (name(hd(cs)).arity!=0) {
157 /* --------------------------------------------------------------------------
158 * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
159 * The derived definitions of equality and ordering are given by:
161 * A a b == A x y = a==x && b==y
166 * compare (A a b) (A x y) = primCompAux a x (compare b y)
167 * compare (B a) (B x) = compare a x
169 * compare a x = cmpConstr a x
171 * In each case, the last line is only needed if there are multiple
172 * constructors in the datatype definition.
173 * ------------------------------------------------------------------------*/
177 static Pair local mkAltEq Args((Int,List));
179 List deriveEq(t) /* generate binding for derived == */
180 Type t; { /* for some TUPLE or DATATYPE t */
182 if (isTycon(t)) { /* deal with type constrs */
183 List cs = tycon(t).defn;
184 for (; hasCfun(cs); cs=tl(cs)) {
185 alts = cons(mkAltEq(tycon(t).line,
186 makeDPats2(hd(cs),name(hd(cs)).arity)),
189 if (cfunOf(hd(tycon(t).defn))!=0) {
190 alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
191 pair(mkInt(tycon(t).line),varFalse)),alts);
194 } else { /* special case for tuples */
195 alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
197 return singleton(mkBind("==",alts));
200 static Pair local mkAltEq(line,pats) /* make alt for an equation for == */
201 Int line; /* using patterns in pats for lhs */
202 List pats; { /* arguments */
204 Cell q = hd(tl(pats));
208 e = ap2(varEq,arg(p),arg(q));
209 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
210 e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
213 return pair(pats,pair(mkInt(line),e));
215 #endif /* DERIVE_EQ */
219 static Pair local mkAltOrd Args((Int,List));
221 List deriveOrd(t) /* make binding for derived compare*/
222 Type t; { /* for some TUPLE or DATATYPE t */
224 if (isEnumType(t)) { /* special case for enumerations */
225 Cell u = inventVar();
226 Cell w = inventVar();
228 if (cfunOf(hd(tycon(t).defn))!=0) {
229 implementConToTag(t);
230 rhs = ap2(varCompare,
231 ap(tycon(t).conToTag,u),
232 ap(tycon(t).conToTag,w));
236 alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
237 } else if (isTycon(t)) { /* deal with type constrs */
238 List cs = tycon(t).defn;
239 for (; hasCfun(cs); cs=tl(cs)) {
240 alts = cons(mkAltOrd(tycon(t).line,
241 makeDPats2(hd(cs),name(hd(cs)).arity)),
244 if (cfunOf(hd(tycon(t).defn))!=0) {
245 Cell u = inventVar();
246 Cell w = inventVar();
247 implementConToTag(t);
248 alts = cons(pair(doubleton(u,w),
249 pair(mkInt(tycon(t).line),
251 ap(tycon(t).conToTag,u),
252 ap(tycon(t).conToTag,w)))),
256 } else { /* special case for tuples */
257 alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
259 return singleton(mkBind("compare",alts));
262 static Pair local mkAltOrd(line,pats) /* make alt for eqn for compare */
263 Int line; /* using patterns in pats for lhs */
264 List pats; { /* arguments */
266 Cell q = hd(tl(pats));
270 e = ap2(varCompare,arg(p),arg(q));
271 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
272 e = ap3(varCompAux,arg(p),arg(q),e);
276 return pair(pats,pair(mkInt(line),e));
278 #endif /* DERIVE_ORD */
280 /* --------------------------------------------------------------------------
281 * Deriving Ix and Enum:
282 * ------------------------------------------------------------------------*/
285 List deriveEnum(t) /* Construct definition of enumeration */
287 Int l = tycon(t).line;
288 Cell x = inventVar();
289 Cell y = inventVar();
290 Cell first = hd(tycon(t).defn);
291 Cell last = tycon(t).defn;
293 if (!isEnumType(t)) {
294 ERRMSG(l) "Can only derive instances of Enum for enumeration types"
297 while (hasCfun(tl(last))) {
301 implementConToTag(t);
302 implementTagToCon(t);
303 return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
304 cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
305 cons(mkBind("enumFrom", singleton(pair(singleton(x), pair(mkInt(l),ap2(varEnumFromTo,x,last))))),
306 /* default instance of enumFromTo is good */
307 cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),pair(mkInt(l),ap3(varEnumFromThenTo,x,y,ap(COND,triple(ap2(varLe,x,y),last,first))))))),
308 /* default instance of enumFromThenTo is good */
311 #endif /* DERIVE_ENUM */
314 static List local mkIxBindsEnum Args((Tycon));
315 static List local mkIxBinds Args((Int,Cell,Int));
316 static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
317 static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
318 static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
320 List deriveIx(t) /* Construct definition of indexing */
322 Int l = tycon(t).line;
323 if (isEnumType(t)) { /* Definitions for enumerations */
324 implementConToTag(t);
325 implementTagToCon(t);
326 return mkIxBindsEnum(t);
327 } else if (isTuple(t)) { /* Definitions for product types */
328 return mkIxBinds(0,t,tupleOf(t));
329 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
330 return mkIxBinds(tycon(t).line,
332 name(hd(tycon(t).defn)).arity);
334 ERRMSG(tycon(t).line)
335 "Can only derive instances of Ix for enumeration or product types"
337 return NIL;/* NOTREACHED*/
340 /* instance Ix T where
341 * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
343 * | inRange b ci = conToTag ci - conToTag c1
344 * | otherwise = error "Ix.index.T: Index out of range."
345 * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
346 * where i = conToTag ci
348 static List local mkIxBindsEnum(t)
350 Int l = tycon(t).line;
351 Name tagToCon = tycon(t).tagToCon;
352 Name conToTag = tycon(t).conToTag;
353 Cell b = inventVar();
354 Cell c1 = inventVar();
355 Cell c2 = inventVar();
356 Cell ci = inventVar();
357 return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,ap2(varEnumFromTo,ap(conToTag,c1),ap(conToTag,c2))))))),
358 cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,ap2(mkTuple(2),c1,c2))),ci),
359 pair(mkInt(l),ap(COND,triple(ap2(varInRange,b,ci),
360 ap2(varMinus,ap(conToTag,ci),ap(conToTag,c1)),
361 ap(varError,mkStr(findText("Ix.index: Index out of range"))))))))),
362 cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),c1,c2),ci), pair(mkInt(l),ap2(varAnd,ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),ap2(varLe,ap(conToTag,ci),ap(conToTag,c2))))))), /* ToDo: share conToTag ci */
366 static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
367 Int line; /* a product type */
370 List vs = getDiVars(3*n);
378 for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
379 ls = ap(ls,hd(vs)); /* of the datatype concerned */
380 us = ap(us,hd(vs=tl(vs)));
381 is = ap(is,hd(vs=tl(vs)));
383 pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
384 pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
386 return cons(prodRange(line,singleton(pr),ls,us,is),
387 cons(prodIndex(line,pats,ls,us,is),
388 cons(prodInRange(line,pats,ls,us,is),
392 static Cell local prodRange(line,pats,ls,us,is)
393 Int line; /* Make definition of range for a */
394 List pats; /* product type */
396 /* range :: (a,a) -> [a]
397 * range (X a b c, X p q r)
398 * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
402 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
403 e = cons(ap(FROMQUAL,pair(arg(is),
404 ap(varRange,ap2(mkTuple(2),
408 e = ap(COMP,pair(is1,e));
409 e = singleton(pair(pats,pair(mkInt(line),e)));
410 return mkBind("range",e);
413 static Cell local prodIndex(line,pats,ls,us,is)
414 Int line; /* Make definition of index for a */
415 List pats; /* product type */
417 /* index :: (a,a) -> a -> Bool
418 * index (X a b c, X p q r) (X x y z)
419 * = index (c,r) z + rangeSize (c,r) * (
420 * index (b,q) y + rangeSize (b,q) * (
425 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
426 xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
428 for (e=hd(xs); nonNull(xs=tl(xs));) {
430 e = ap2(varPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
432 e = singleton(pair(pats,pair(mkInt(line),e)));
433 return mkBind("index",e);
436 static Cell local prodInRange(line,pats,ls,us,is)
437 Int line; /* Make definition of inRange for a*/
438 List pats; /* product type */
440 /* inRange :: (a,a) -> a -> Bool
441 * inRange (X a b c, X p q r) (X x y z)
442 * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
444 Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
445 while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
447 ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
450 e = singleton(pair(pats,pair(mkInt(line),e)));
451 return mkBind("inRange",e);
453 #endif /* DERIVE_IX */
455 /* --------------------------------------------------------------------------
457 * ------------------------------------------------------------------------*/
461 static Cell local mkAltShow Args((Int,Cell,Int));
462 static Cell local showsPrecRhs Args((Cell,Cell));
464 List deriveShow(t) /* Construct definition of text conversion */
467 if (isTycon(t)) { /* deal with type constrs */
468 List cs = tycon(t).defn;
469 for (; hasCfun(cs); cs=tl(cs)) {
470 alts = cons(mkAltShow(tycon(t).line,hd(cs),name(hd(cs)).arity),
474 } else { /* special case for tuples */
475 alts = singleton(mkAltShow(0,t,tupleOf(t)));
477 return singleton(mkBind("showsPrec",alts));
480 static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
484 List vs = getDiVars(a+1);
487 while (vs=tl(vs), 0<a--) {
488 pat = ap(pat,hd(vs));
490 return pair(doubleton(d,pat),
491 pair(mkInt(line),showsPrecRhs(d,pat)));
494 #define consChar(c) ap(conCons,mkChar(c))
495 #define shows0 ap(varShowsPrec,mkInt(0))
496 #define shows10 ap(varShowsPrec,mkInt(10))
497 #define showsOP ap(varCompose,consChar('('))
498 #define showsOB ap(varCompose,consChar('{'))
499 #define showsCM ap(varCompose,consChar(','))
500 #define showsSP ap(varCompose,consChar(' '))
501 #define showsBQ ap(varCompose,consChar('`'))
502 #define showsCP consChar(')')
503 #define showsCB consChar('}')
505 static Cell local showsPrecRhs(d,pat) /* build a rhs for showsPrec for a */
506 Cell d, pat; { /* given pattern, pat */
507 Cell h = getHead(pat);
508 List cfs = cfunSfuns;
511 /* To display a tuple:
512 * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
513 * showChar ',' . showsPrec 0 b .
514 * showChar ',' . showsPrec 0 c .
515 * showChar ',' . showsPrec 0 d .
521 rhs = ap(showsCM,ap2(varCompose,ap(shows0,arg(pat)),rhs));
524 return ap(showsOP,ap2(varCompose,ap(shows0,arg(pat)),rhs));
527 for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
530 /* To display a value using record syntax:
531 * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
532 * showField "x" e . showChar ',' .
533 * showField "y" f . showChar ',' .
534 * showField "z" g . showChar '}'
536 * = showString lab . showChar '=' . shows val
539 List vs = revDupOnto(snd(hd(cfs)),NIL);
542 rhs = ap2(varCompose,
544 mkStr(textOf(hd(vs))),
550 rhs = ap(showsCM,rhs);
556 rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),ap(showsOB,rhs));
558 } else if (name(h).arity==0) {
559 /* To display a nullary constructor:
560 * showsPrec d Foo = showString "Foo"
562 return ap(varAppend,mkStr(name(h).text));
564 Syntax s = syntaxOf(name(h).text);
565 if (name(h).arity==2 && assocOf(s)!=APPLIC) {
566 /* For a binary constructor with prec p:
567 * showsPrec d (a :* b) = showParen (d > p)
568 * (showsPrec lp a . showChar ' ' .
569 * showsString s . showChar ' ' .
573 Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
574 Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
575 Cell rhs = ap(showsSP,ap2(varShowsPrec,mkInt(rp),arg(pat)));
576 if (defaultSyntax(name(h).text)==APPLIC) {
579 ap(varAppend,mkStr(name(h).text)),
582 rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
584 rhs = ap2(varCompose,
585 ap2(varShowsPrec,mkInt(lp),arg(fun(pat))),
587 rhs = ap2(varShowParen,ap2(varLe,mkInt(p+1),d),rhs);
590 /* To display a non-nullary constructor with applicative syntax:
591 * showsPrec d (Foo x y) = showParen (d>=10)
592 * (showString "Foo" .
593 * showChar ' ' . showsPrec 10 x .
594 * showChar ' ' . showsPrec 10 y)
596 Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
597 for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
598 rhs = ap(showsSP,ap2(varCompose,ap(shows10,arg(pat)),rhs));
600 rhs = ap2(varCompose,ap(varAppend,mkStr(name(h).text)),rhs);
601 rhs = ap2(varShowParen,ap2(varLe,mkInt(10),d),rhs);
617 #endif /* DERIVE_SHOW */
619 /* --------------------------------------------------------------------------
621 * ------------------------------------------------------------------------*/
625 static Cell local mkReadCon Args((Name,Cell,Cell));
626 static Cell local mkReadPrefix Args((Cell));
627 static Cell local mkReadInfix Args((Cell));
628 static Cell local mkReadTuple Args((Cell));
629 static Cell local mkReadRecord Args((Cell,List));
631 #define Tuple2(f,s) ap2(mkTuple(2),f,s)
632 #define Lex(r) ap(varLex,r)
633 #define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
634 #define ReadsPrec(n,e) ap2(varReadsPrec,n,e)
635 #define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
636 #define ReadParen(a,b,c) ap3(varReadParen,a,b,c)
637 #define ReadField(f,s) ap2(varReadField,f,s)
638 #define GT(l,r) ap2(varGt,l,r)
639 #define Append(a,b) ap2(varAppend,a,b)
641 /* Construct the readsPrec function of the form:
643 * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
644 * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
646 * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
648 List deriveRead(t) /* construct definition of text reader */
652 Cell d = inventVar();
653 Cell r = inventVar();
654 List pat = cons(d,cons(r,NIL));
658 List cs = tycon(t).defn;
660 for(; hasCfun(cs); cs=tl(cs)) {
661 exps = cons(mkReadCon(hd(cs),d,r),exps);
663 /* reverse concatenate list of subexpressions */
665 for(exps=tl(exps); nonNull(exps); exps=tl(exps)) {
666 exp = ap2(varAppend,hd(exps),exp);
668 line = tycon(t).line;
669 } else { /* Tuples */
670 exp = ap(mkReadTuple(t),r);
672 /* printExp(stdout,exp); putc('\n',stdout); */
673 alt = pair(pat,pair(mkInt(line),exp));
674 return singleton(mkBind("readsPrec",singleton(alt)));
677 /* Generate an expression of the form:
679 * readParen (d > p) <derived expression> r
681 * for a (non-tuple) constructor "con" of precedence "p".
683 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
689 Syntax s = syntaxOf(name(con).text);
690 List cfs = cfunSfuns;
691 for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
694 exp = mkReadRecord(con,snd(hd(cfs)));
696 } else if (name(con).arity==2 && assocOf(s)!=APPLIC) {
697 exp = mkReadInfix(con);
700 exp = mkReadPrefix(con);
703 return ReadParen(name(con).arity==0 ? varFalse : GT(d,mkInt(p)),
708 /* Given an n-ary prefix constructor, generate a single lambda
709 * expression, such that
711 * data T ... = Constr a1 a2 .. an | ....
715 * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
716 * (t1,s1) <- readsPrec 10 s0,
717 * (t2,s2) <- readsPrec 10 s1,
719 * (tn,sn) <- readsPrec 10 sn-1 ]
722 static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
724 Int arity = name(con).arity;
725 Cell cn = mkStr(name(con).text);
726 Cell r = inventVar();
727 Cell prev_s = inventVar();
732 /* build (reversed) list of qualifiers and constructor */
733 quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
734 for(i=0; i<arity; i++) {
735 Cell t = inventVar();
736 Cell s = inventVar();
737 quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
742 /* \r -> [ (exp, prev_s) | quals ] */
743 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
746 /* Given a binary infix constructor of precedence p
748 * ... | T1 `con` T2 | ...
750 * generate the lambda expression
752 * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
753 * ("con",s1) <- lex s0,
754 * (v,s2) <- readsPrec rp s1 ]
756 * where lp and rp are either p or p+1 depending on associativity
758 static Cell local mkReadInfix( con )
761 Syntax s = syntaxOf(name(con).text);
763 Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
764 Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
765 Cell cn = mkStr(name(con).text);
766 Cell r = inventVar();
767 Cell s0 = inventVar();
768 Cell s1 = inventVar();
769 Cell s2 = inventVar();
770 Cell u = inventVar();
771 Cell v = inventVar();
774 quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
775 quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
776 quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
778 return Lambda(singleton(r),
779 ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
782 /* Given the n-ary tuple constructor return a lambda expression:
784 * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
785 * (t1, s1) <- readsPrec 0 s0,
787 * (",",s(2n-1)) <- lex s(2n-2),
788 * (tn, s(2n)) <- readsPrec 0 s(2n-1),
789 * (")",s(2n+1)) <- lex s(2n) ]
791 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
793 Int arity = tupleOf(tup);
794 Cell lp = mkStr(findText("("));
795 Cell rp = mkStr(findText(")"));
796 Cell co = mkStr(findText(","));
798 Cell r = inventVar();
800 Cell s = inventVar();
805 /* build (reversed) list of qualifiers and constructor */
806 for(i=0; i<arity; i++) {
807 Cell t = inventVar();
808 Cell si = inventVar();
809 Cell sj = inventVar();
810 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
811 quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
816 quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
818 /* \ r -> [ (exp,s) | quals ] */
819 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
822 /* Given a record constructor
824 * ... | C { f1 :: T1, ... fn :: Tn } | ...
826 * generate the expression:
828 * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
829 * ("{", s1) <- lex s0,
830 * (t1, s2) <- readField "f1" s1,
832 * (",", s(2n-1)) <- lex s(2n),
833 * (tn, s(2n)) <- readField "fn" s(2n+1),
834 * ("}", s(2n+1)) <- lex s(2n+2) ]
838 * readField :: Read a => String -> ReadS a
839 * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
840 * ("=",s2) <- lex s1,
841 * r <- readsPrec 10 s2 ]
843 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
846 Cell cn = mkStr(name(con).text);
847 Cell lb = mkStr(findText("{"));
848 Cell rb = mkStr(findText("}"));
849 Cell co = mkStr(findText(","));
851 Cell r = inventVar();
852 Cell s0 = inventVar();
854 Cell s = inventVar();
858 /* build (reversed) list of qualifiers and constructor */
859 quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
860 for(; nonNull(fs); fs=tl(fs)) {
861 Cell f = mkStr(textOf(hd(fs)));
862 Cell t = inventVar();
863 Cell si = inventVar();
864 Cell sj = inventVar();
865 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
866 quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
871 quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
873 /* \ r -> [ (exp,s) | quals ] */
874 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
887 #endif /* DERIVE_READ */
889 /* --------------------------------------------------------------------------
891 * ------------------------------------------------------------------------*/
895 static List local mkBndBinds Args((Int,Cell,Int));
897 List deriveBounded(t) /* construct definition of bounds */
900 Cell last = tycon(t).defn;
901 Cell first = hd(last);
902 while (hasCfun(tl(last))) {
905 return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
906 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
908 } else if (isTuple(t)) { /* Definitions for product types */
909 return mkBndBinds(0,t,tupleOf(t));
910 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
911 return mkBndBinds(tycon(t).line,
913 name(hd(tycon(t).defn)).arity);
915 ERRMSG(tycon(t).line)
916 "Can only derive instances of Bounded for enumeration and product types"
921 static List local mkBndBinds(line,h,n) /* build bindings for derived */
922 Int line; /* Bounded on a product type */
928 minB = ap(minB,varMinBound);
929 maxB = ap(maxB,varMaxBound);
931 return cons(mkBind("minBound",mkVarAlts(line,minB)),
932 cons(mkBind("maxBound",mkVarAlts(line,maxB)),
936 #endif /* DERIVE_BOUNDED */
938 /* --------------------------------------------------------------------------
939 * Static Analysis control:
940 * ------------------------------------------------------------------------*/
942 Void deriveControl(what)
944 Text textPrelude = findText("PreludeBuiltin");
947 varTrue = mkQVar(textPrelude,findText("True"));
948 varFalse = mkQVar(textPrelude,findText("False"));
950 varCompAux = mkQVar(textPrelude,findText("primCompAux"));
951 varCompare = mkQVar(textPrelude,findText("compare"));
952 varEQ = mkQVar(textPrelude,findText("EQ"));
955 varRangeSize = mkQVar(textPrelude,findText("rangeSize"));
956 varInRange = mkQVar(textPrelude,findText("inRange"));
957 varRange = mkQVar(textPrelude,findText("range"));
958 varIndex = mkQVar(textPrelude,findText("index"));
959 varMult = mkQVar(textPrelude,findText("*"));
960 varPlus = mkQVar(textPrelude,findText("+"));
961 varMap = mkQVar(textPrelude,findText("map"));
962 varMinus = mkQVar(textPrelude,findText("-"));
963 varError = mkQVar(textPrelude,findText("error"));
966 varToEnum = mkQVar(textPrelude,findText("toEnum"));
967 varFromEnum = mkQVar(textPrelude,findText("fromEnum"));
968 varEnumFromTo = mkQVar(textPrelude,findText("enumFromTo"));
969 varEnumFromThenTo = mkQVar(textPrelude,findText("enumFromThenTo"));
972 varMinBound = mkQVar(textPrelude,findText("minBound"));
973 varMaxBound = mkQVar(textPrelude,findText("maxBound"));
976 conCons = mkQCon(textPrelude,findText(":"));
977 varShowField = mkQVar(textPrelude,findText("primShowField"));
978 varShowParen = mkQVar(textPrelude,findText("showParen"));
979 varCompose = mkQVar(textPrelude,findText("."));
980 varShowsPrec = mkQVar(textPrelude,findText("showsPrec"));
981 varLe = mkQVar(textPrelude,findText("<="));
984 varReadField = mkQVar(textPrelude,findText("primReadField"));
985 varReadParen = mkQVar(textPrelude,findText("readParen"));
986 varLex = mkQVar(textPrelude,findText("lex"));
987 varReadsPrec = mkQVar(textPrelude,findText("readsPrec"));
988 varGt = mkQVar(textPrelude,findText(">"));
990 #if DERIVE_SHOW || DERIVE_READ
991 varAppend = mkQVar(textPrelude,findText("++"));
993 #if DERIVE_EQ || DERIVE_IX
994 varAnd = mkQVar(textPrelude,findText("&&"));
996 #if DERIVE_EQ || DERIVE_ORD
997 varEq = mkQVar(textPrelude,findText("=="));
999 /* deliberate fall through */
1003 #if DERIVE_SHOW | DERIVE_READ
1010 #if DERIVE_SHOW | DERIVE_READ
1034 mark(varEnumFromTo);
1035 mark(varEnumFromThenTo);
1056 #if DERIVE_SHOW || DERIVE_READ
1059 #if DERIVE_EQ || DERIVE_IX
1062 #if DERIVE_EQ || DERIVE_ORD
1069 /*-------------------------------------------------------------------------*/