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/04/27 10:06:50 $
12 * ------------------------------------------------------------------------*/
19 #include "Assembler.h"
22 List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
24 /* --------------------------------------------------------------------------
25 * local function prototypes:
26 * ------------------------------------------------------------------------*/
28 static List local getDiVars Args((Int));
29 static Cell local mkBind Args((String,List));
30 static Cell local mkVarAlts Args((Int,Cell));
31 static List local makeDPats2 Args((Cell,Int));
32 static Bool local isEnumType Args((Tycon));
33 static Pair local mkAltEq Args((Int,List));
34 static Pair local mkAltOrd Args((Int,List));
35 static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
36 static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
37 static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
38 static List local mkIxBinds Args((Int,Cell,Int));
39 static Cell local mkAltShow Args((Int,Cell,Int));
40 static Cell local showsPrecRhs Args((Cell,Cell,Int));
41 static Cell local mkReadCon Args((Name,Cell,Cell));
42 static Cell local mkReadPrefix Args((Cell));
43 static Cell local mkReadInfix Args((Cell));
44 static Cell local mkReadTuple Args((Cell));
45 static Cell local mkReadRecord Args((Cell,List));
46 static List local mkBndBinds Args((Int,Cell,Int));
49 /* --------------------------------------------------------------------------
51 * ------------------------------------------------------------------------*/
53 List diVars = NIL; /* Acts as a cache of invented vars*/
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);
64 static Cell local mkBind(s,alts) /* make a binding for a variable */
67 return pair(mkVar(findText(s)),pair(NIL,alts));
70 static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
71 Int line; /* a simple expression */
73 return singleton(pair(NIL,pair(mkInt(line),r)));
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);
84 for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
90 for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
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) {
106 /* ToDo: correct? addCfunTable(t); */
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:
117 * A a b == A x y = a==x && b==y
122 * compare (A a b) (A x y) = primCompAux a x (compare b y)
123 * compare (B a) (B x) = compare a x
125 * compare a x = cmpConstr a x
127 * In each case, the last line is only needed if there are multiple
128 * constructors in the datatype definition.
129 * ------------------------------------------------------------------------*/
131 static Pair local mkAltEq Args((Int,List));
133 List deriveEq(t) /* generate binding for derived == */
134 Type t; { /* for some TUPLE or DATATYPE t */
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)))),
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);
148 } else { /* special case for tuples */
149 alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
151 return singleton(mkBind("==",alts));
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 */
158 Cell q = hd(tl(pats));
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);
167 return pair(pats,pair(mkInt(line),e));
171 static Pair local mkAltOrd Args((Int,List));
173 List deriveOrd(t) /* make binding for derived compare*/
174 Type t; { /* for some TUPLE or DATATYPE t */
176 if (isEnumType(t)) { /* special case for enumerations */
177 Cell u = inventVar();
178 Cell w = inventVar();
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));
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)))),
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),
203 ap(tycon(t).conToTag,u),
204 ap(tycon(t).conToTag,w)))),
208 } else { /* special case for tuples */
209 alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
211 return singleton(mkBind("compare",alts));
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 */
218 Cell q = hd(tl(pats));
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);
228 return pair(pats,pair(mkInt(line),e));
232 /* --------------------------------------------------------------------------
233 * Deriving Ix and Enum:
234 * ------------------------------------------------------------------------*/
236 List deriveEnum(t) /* Construct definition of enumeration */
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;
244 if (!isEnumType(t)) {
245 ERRMSG(l) "Can only derive instances of Enum for enumeration types"
248 while (hasCfun(tl(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 cons(mkBind("enumFrom", singleton(pair(singleton(x),
258 ap2(nameFromTo,x,last))))),
259 /* default instance of enumFromTo is good */
260 cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
262 ap3(nameFromThenTo,x,y,
263 ap(COND,triple(ap2(nameLe,x,y),
265 /* default instance of enumFromThenTo is good */
270 static List local mkIxBindsEnum Args((Tycon));
271 static List local mkIxBinds Args((Int,Cell,Int));
272 static Cell local prodRange Args((Int,List,Cell,Cell,Cell));
273 static Cell local prodIndex Args((Int,List,Cell,Cell,Cell));
274 static Cell local prodInRange Args((Int,List,Cell,Cell,Cell));
276 List deriveIx(t) /* Construct definition of indexing */
278 if (isEnumType(t)) { /* Definitions for enumerations */
279 implementConToTag(t);
280 implementTagToCon(t);
281 return mkIxBindsEnum(t);
282 } else if (isTuple(t)) { /* Definitions for product types */
283 return mkIxBinds(0,t,tupleOf(t));
284 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
285 return mkIxBinds(tycon(t).line,
287 userArity(hd(tycon(t).defn)));
289 ERRMSG(tycon(t).line)
290 "Can only derive instances of Ix for enumeration or product types"
292 return NIL;/* NOTREACHED*/
295 /* instance Ix T where
296 * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
298 * | inRange b ci = conToTag ci - conToTag c1
299 * | otherwise = error "Ix.index.T: Index out of range."
300 * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
301 * where i = conToTag ci
303 static List local mkIxBindsEnum(t)
305 Int l = tycon(t).line;
306 Name tagToCon = tycon(t).tagToCon;
307 Name conToTag = tycon(t).conToTag;
308 Cell b = inventVar();
309 Cell c1 = inventVar();
310 Cell c2 = inventVar();
311 Cell ci = inventVar();
312 return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
313 c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon,
314 ap2(nameFromTo,ap(conToTag,c1),
315 ap(conToTag,c2))))))),
316 cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
317 ap2(mkTuple(2),c1,c2))),ci),
318 pair(mkInt(l),ap(COND,
319 triple(ap2(nameInRange,b,ci),
320 ap2(nameMinus,ap(conToTag,ci),
322 ap(nameError,mkStr(findText(
323 "Ix.index: Index out of range"))))))))),
324 cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
325 c1,c2),ci), pair(mkInt(l),ap2(nameAnd,
326 ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
327 ap2(nameLe,ap(conToTag,ci),
328 ap(conToTag,c2))))))),
329 /* ToDo: share conToTag ci */
333 static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
334 Int line; /* a product type */
337 List vs = getDiVars(3*n);
345 for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
346 ls = ap(ls,hd(vs)); /* of the datatype concerned */
347 us = ap(us,hd(vs=tl(vs)));
348 is = ap(is,hd(vs=tl(vs)));
350 pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
351 pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
353 return cons(prodRange(line,singleton(pr),ls,us,is),
354 cons(prodIndex(line,pats,ls,us,is),
355 cons(prodInRange(line,pats,ls,us,is),
359 static Cell local prodRange(line,pats,ls,us,is)
360 Int line; /* Make definition of range for a */
361 List pats; /* product type */
363 /* range :: (a,a) -> [a]
364 * range (X a b c, X p q r)
365 * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
369 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
370 e = cons(ap(FROMQUAL,pair(arg(is),
371 ap(nameRange,ap2(mkTuple(2),
375 e = ap(COMP,pair(is1,e));
376 e = singleton(pair(pats,pair(mkInt(line),e)));
377 return mkBind("range",e);
380 static Cell local prodIndex(line,pats,ls,us,is)
381 Int line; /* Make definition of index for a */
382 List pats; /* product type */
384 /* index :: (a,a) -> a -> Bool
385 * index (X a b c, X p q r) (X x y z)
386 * = index (c,r) z + rangeSize (c,r) * (
387 * index (b,q) y + rangeSize (b,q) * (
392 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
393 xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
395 for (e=hd(xs); nonNull(xs=tl(xs));) {
397 e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
399 e = singleton(pair(pats,pair(mkInt(line),e)));
400 return mkBind("index",e);
403 static Cell local prodInRange(line,pats,ls,us,is)
404 Int line; /* Make definition of inRange for a*/
405 List pats; /* product type */
407 /* inRange :: (a,a) -> a -> Bool
408 * inRange (X a b c, X p q r) (X x y z)
409 * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
411 Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
412 while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
414 ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
417 e = singleton(pair(pats,pair(mkInt(line),e)));
418 return mkBind("inRange",e);
422 /* --------------------------------------------------------------------------
424 * ------------------------------------------------------------------------*/
426 List deriveShow(t) /* Construct definition of text conversion */
429 if (isTycon(t)) { /* deal with type constrs */
430 List cs = tycon(t).defn;
431 for (; hasCfun(cs); cs=tl(cs)) {
432 alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
436 } else { /* special case for tuples */
437 alts = singleton(mkAltShow(0,t,tupleOf(t)));
439 return singleton(mkBind("showsPrec",alts));
442 static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
446 List vs = getDiVars(a+1);
451 for (vs=tl(vs); i<a; i++) {
452 pat = ap(pat,hd(vs));
455 pats = cons(d,cons(pat,NIL));
456 return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
459 #define shows0 ap(nameShowsPrec,mkInt(0))
460 #define shows10 ap(nameShowsPrec,mkInt(10))
461 #define showsOP ap(nameComp,consChar('('))
462 #define showsOB ap(nameComp,consChar('{'))
463 #define showsCM ap(nameComp,consChar(','))
464 #define showsSP ap(nameComp,consChar(' '))
465 #define showsBQ ap(nameComp,consChar('`'))
466 #define showsCP consChar(')')
467 #define showsCB consChar('}')
469 static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
470 Cell d, pat; /* given pattern, pat */
472 Cell h = getHead(pat);
473 List cfs = cfunSfuns;
476 /* To display a tuple:
477 * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
478 * showChar ',' . showsPrec 0 b .
479 * showChar ',' . showsPrec 0 c .
480 * showChar ',' . showsPrec 0 d .
486 rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
489 return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
492 for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
495 /* To display a value using record syntax:
496 * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
497 * showField "x" e . showChar ',' .
498 * showField "y" f . showChar ',' .
499 * showField "z" g . showChar '}'
501 * = showString lab . showChar '=' . shows val
504 List vs = dupOnto(snd(hd(cfs)),NIL);
509 mkStr(textOf(hd(vs))),
515 rhs = ap(showsCM,rhs);
521 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
525 /* To display a nullary constructor:
526 * showsPrec d Foo = showString "Foo"
528 return ap(nameApp,mkStr(name(h).text));
530 Syntax s = syntaxOf(h);
531 if (a==2 && assocOf(s)!=APPLIC) {
532 /* For a binary constructor with prec p:
533 * showsPrec d (a :* b) = showParen (d > p)
534 * (showsPrec lp a . showChar ' ' .
535 * showsString s . showChar ' ' .
539 Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
540 Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
541 Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
542 if (defaultSyntax(name(h).text)==APPLIC) {
545 ap(nameApp,mkStr(name(h).text)),
548 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
552 ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
554 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
558 /* To display a non-nullary constructor with applicative syntax:
559 * showsPrec d (Foo x y) = showParen (d>=10)
560 * (showString "Foo" .
561 * showChar ' ' . showsPrec 10 x .
562 * showChar ' ' . showsPrec 10 y)
564 Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
565 for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
566 rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
568 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
569 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
584 /* --------------------------------------------------------------------------
586 * ------------------------------------------------------------------------*/
588 #define Tuple2(f,s) ap2(mkTuple(2),f,s)
589 #define Lex(r) ap(nameLex,r)
590 #define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
591 #define ReadsPrec(n,e) ap2(nameReadsPrec,n,e)
592 #define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
593 #define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
594 #define ReadField(f,s) ap2(nameReadField,f,s)
595 #define GT(l,r) ap2(nameGt,l,r)
596 #define Append(a,b) ap2(nameApp,a,b)
598 /* Construct the readsPrec function of the form:
600 * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
601 * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
603 * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
605 List deriveRead(t) /* construct definition of text reader */
609 Cell d = inventVar();
610 Cell r = inventVar();
611 List pat = cons(d,cons(r,NIL));
615 List cs = tycon(t).defn;
617 for (; hasCfun(cs); cs=tl(cs)) {
618 exps = cons(mkReadCon(hd(cs),d,r),exps);
620 /* reverse concatenate list of subexpressions */
622 for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
623 exp = ap2(nameApp,hd(exps),exp);
625 line = tycon(t).line;
628 exp = ap(mkReadTuple(t),r);
630 /* printExp(stdout,exp); putc('\n',stdout); */
631 alt = pair(pat,pair(mkInt(line),exp));
632 return singleton(mkBind("readsPrec",singleton(alt)));
635 /* Generate an expression of the form:
637 * readParen (d > p) <derived expression> r
639 * for a (non-tuple) constructor "con" of precedence "p".
642 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
648 Syntax s = syntaxOf(con);
649 List cfs = cfunSfuns;
650 for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
653 exp = mkReadRecord(con,snd(hd(cfs)));
654 return ReadParen(nameFalse, exp, r);
657 if (userArity(con)==2 && assocOf(s)!=APPLIC) {
658 exp = mkReadInfix(con);
661 exp = mkReadPrefix(con);
664 return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
667 /* Given an n-ary prefix constructor, generate a single lambda
668 * expression, such that
670 * data T ... = Constr a1 a2 .. an | ....
674 * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
675 * (t1,s1) <- readsPrec 10 s0,
676 * (t2,s2) <- readsPrec 10 s1,
678 * (tn,sn) <- readsPrec 10 sn-1 ]
681 static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
683 Int arity = userArity(con);
684 Cell cn = mkStr(name(con).text);
685 Cell r = inventVar();
686 Cell prev_s = inventVar();
691 /* build (reversed) list of qualifiers and constructor */
692 quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
693 for(i=0; i<arity; i++) {
694 Cell t = inventVar();
695 Cell s = inventVar();
696 quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
701 /* \r -> [ (exp, prev_s) | quals ] */
702 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
705 /* Given a binary infix constructor of precedence p
707 * ... | T1 `con` T2 | ...
709 * generate the lambda expression
711 * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
712 * ("con",s1) <- lex s0,
713 * (v,s2) <- readsPrec rp s1 ]
715 * where lp and rp are either p or p+1 depending on associativity
717 static Cell local mkReadInfix( con )
720 Syntax s = syntaxOf(con);
722 Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
723 Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
724 Cell cn = mkStr(name(con).text);
725 Cell r = inventVar();
726 Cell s0 = inventVar();
727 Cell s1 = inventVar();
728 Cell s2 = inventVar();
729 Cell u = inventVar();
730 Cell v = inventVar();
733 quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
734 quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
735 quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
737 return Lambda(singleton(r),
738 ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
741 /* Given the n-ary tuple constructor return a lambda expression:
743 * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
744 * (t1, s1) <- readsPrec 0 s0,
746 * (",",s(2n-1)) <- lex s(2n-2),
747 * (tn, s(2n)) <- readsPrec 0 s(2n-1),
748 * (")",s(2n+1)) <- lex s(2n) ]
750 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
752 Int arity = tupleOf(tup);
753 Cell lp = mkStr(findText("("));
754 Cell rp = mkStr(findText(")"));
755 Cell co = mkStr(findText(","));
757 Cell r = inventVar();
759 Cell s = inventVar();
764 /* build (reversed) list of qualifiers and constructor */
765 for(i=0; i<arity; i++) {
766 Cell t = inventVar();
767 Cell si = inventVar();
768 Cell sj = inventVar();
769 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
770 quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
775 quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
777 /* \ r -> [ (exp,s) | quals ] */
778 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
781 /* Given a record constructor
783 * ... | C { f1 :: T1, ... fn :: Tn } | ...
785 * generate the expression:
787 * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
788 * ("{", s1) <- lex s0,
789 * (t1, s2) <- readField "f1" s1,
791 * (",", s(2n-1)) <- lex s(2n),
792 * (tn, s(2n)) <- readField "fn" s(2n+1),
793 * ("}", s(2n+1)) <- lex s(2n+2) ]
797 * readField :: Read a => String -> ReadS a
798 * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
799 * ("=",s2) <- lex s1,
800 * r <- readsPrec 10 s2 ]
802 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
805 Cell cn = mkStr(name(con).text);
806 Cell lb = mkStr(findText("{"));
807 Cell rb = mkStr(findText("}"));
808 Cell co = mkStr(findText(","));
810 Cell r = inventVar();
811 Cell s0 = inventVar();
813 Cell s = inventVar();
817 /* build (reversed) list of qualifiers and constructor */
818 quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
819 for(; nonNull(fs); fs=tl(fs)) {
820 Cell f = mkStr(textOf(hd(fs)));
821 Cell t = inventVar();
822 Cell si = inventVar();
823 Cell sj = inventVar();
824 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
825 quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
830 quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
832 /* \ r -> [ (exp,s) | quals ] */
833 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
846 /* --------------------------------------------------------------------------
848 * ------------------------------------------------------------------------*/
850 List deriveBounded(t) /* construct definition of bounds */
853 Cell last = tycon(t).defn;
854 Cell first = hd(last);
855 while (hasCfun(tl(last))) {
858 return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
859 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
861 } else if (isTuple(t)) { /* Definitions for product types */
862 return mkBndBinds(0,t,tupleOf(t));
863 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
864 return mkBndBinds(tycon(t).line,
866 userArity(hd(tycon(t).defn)));
868 ERRMSG(tycon(t).line)
869 "Can only derive instances of Bounded for enumeration and product types"
874 static List local mkBndBinds(line,h,n) /* build bindings for derived */
875 Int line; /* Bounded on a product type */
881 minB = ap(minB,nameMinBnd);
882 maxB = ap(maxB,nameMaxBnd);
884 return cons(mkBind("minBound",mkVarAlts(line,minB)),
885 cons(mkBind("maxBound",mkVarAlts(line,maxB)),
890 /* --------------------------------------------------------------------------
891 * Helpers: conToTag and tagToCon
892 * ------------------------------------------------------------------------*/
894 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
895 Void implementConToTag(t)
897 if (isNull(tycon(t).conToTag)) {
898 List cs = tycon(t).defn;
899 Name nm = newName(inventText(),NIL);
900 StgVar v = mkStgVar(NIL,NIL);
901 List alts = NIL; /* can't fail */
903 assert(isTycon(t) && (tycon(t).what==DATATYPE
904 || tycon(t).what==NEWTYPE));
905 for (; hasCfun(cs); cs=tl(cs)) {
907 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
908 StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
910 StgExpr tag = mkStgLet(singleton(r),r);
913 for(i=0; i < name(c).arity; ++i) {
914 vs = cons(mkStgVar(NIL,NIL),vs);
916 alts = cons(mkStgCaseAlt(c,vs,tag),alts);
919 name(nm).line = tycon(t).line;
920 name(nm).type = conToTagType(t);
922 name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
924 name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar));
925 tycon(t).conToTag = nm;
926 /* hack to make it print out */
927 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
931 /* \ v -> case v of { ...; i -> Ci; ... } */
932 Void implementTagToCon(t)
934 if (isNull(tycon(t).tagToCon)) {
948 assert(nameUnpackString);
950 assert(isTycon(t) && (tycon(t).what==DATATYPE
951 || tycon(t).what==NEWTYPE));
953 tyconname = textToStr(tycon(t).text);
954 if (strlen(tyconname) > 100)
955 internal("implementTagToCon: tycon name too long");
958 "out-of-range arg for `toEnum' "
959 "in derived `instance Enum %s'",
963 nm = newName(inventText(),NIL);
964 v1 = mkStgVar(NIL,NIL);
965 v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
967 txt0 = mkStr(findText(etxt));
968 bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
969 bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
970 bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
975 mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
977 makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
981 for (; hasCfun(cs); cs=tl(cs)) {
983 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
984 StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
985 assert(name(c).arity==0);
986 alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
989 name(nm).line = tycon(t).line;
990 name(nm).type = tagToConType(t);
992 name(nm).stgVar = mkStgVar(
1001 mkStgPrimCase(v2,alts))))),
1004 name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar));
1005 tycon(t).tagToCon = nm;
1006 /* hack to make it print out */
1007 stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals);
1012 /* --------------------------------------------------------------------------
1013 * Derivation control:
1014 * ------------------------------------------------------------------------*/
1016 Void deriveControl(what)
1020 /* deliberate fall through */
1034 /*-------------------------------------------------------------------------*/