2 /* --------------------------------------------------------------------------
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.
11 * $RCSfile: derive.c,v $
13 * $Date: 2000/04/27 16:35:29 $
14 * ------------------------------------------------------------------------*/
16 #include "hugsbasictypes.h"
21 #include "Rts.h" /* to make StgPtr visible in Assembler.h */
22 #include "Assembler.h"
24 List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
26 /* --------------------------------------------------------------------------
27 * local function prototypes:
28 * ------------------------------------------------------------------------*/
30 static List local getDiVars ( Int );
31 static Cell local mkBind ( String,List );
32 static Cell local mkVarAlts ( Int,Cell );
33 static List local makeDPats2 ( Cell,Int );
34 static Bool local isEnumType ( Tycon );
35 static Pair local mkAltEq ( Int,List );
36 static Pair local mkAltOrd ( Int,List );
37 static Cell local prodRange ( Int,List,Cell,Cell,Cell );
38 static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
39 static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
40 static List local mkIxBinds ( Int,Cell,Int );
41 static Cell local mkAltShow ( Int,Cell,Int );
42 static Cell local showsPrecRhs ( Cell,Cell,Int );
43 static Cell local mkReadCon ( Name,Cell,Cell );
44 static Cell local mkReadPrefix ( Cell );
45 static Cell local mkReadInfix ( Cell );
46 static Cell local mkReadTuple ( Cell );
47 static Cell local mkReadRecord ( Cell,List );
48 static List local mkBndBinds ( Int,Cell,Int );
51 /* --------------------------------------------------------------------------
53 * ------------------------------------------------------------------------*/
55 List diVars = NIL; /* Acts as a cache of invented vars*/
58 static List local getDiVars(n) /* get list of at least n vars for */
59 Int n; { /* derived instance generation */
60 for (; diNum<n; diNum++) {
61 diVars = cons(inventVar(),diVars);
66 static Cell local mkBind(s,alts) /* make a binding for a variable */
69 return pair(mkVar(findText(s)),pair(NIL,alts));
72 static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
73 Int line; /* a simple expression */
75 return singleton(pair(NIL,pair(mkInt(line),r)));
78 static List local makeDPats2(h,n) /* generate pattern list */
79 Cell h; /* by putting two new patterns with*/
80 Int n; { /* head h and new var components */
81 List us = getDiVars(2*n);
86 for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
92 for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
99 static Bool local isEnumType(t) /* Determine whether t is an enumeration */
100 Tycon t; { /* type (i.e. all constructors arity == 0) */
101 if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
102 List cs = tycon(t).defn;
103 for (; hasCfun(cs); cs=tl(cs)) {
104 if (name(hd(cs)).arity!=0) {
108 /* ToDo: correct? addCfunTable(t); */
115 /* --------------------------------------------------------------------------
116 * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
117 * The derived definitions of equality and ordering are given by:
119 * A a b == A x y = a==x && b==y
124 * compare (A a b) (A x y) = primCompAux a x (compare b y)
125 * compare (B a) (B x) = compare a x
127 * compare a x = cmpConstr a x
129 * In each case, the last line is only needed if there are multiple
130 * constructors in the datatype definition.
131 * ------------------------------------------------------------------------*/
133 static Pair local mkAltEq ( Int,List );
135 List deriveEq(t) /* generate binding for derived == */
136 Type t; { /* for some TUPLE or DATATYPE t */
138 if (isTycon(t)) { /* deal with type constrs */
139 List cs = tycon(t).defn;
140 for (; hasCfun(cs); cs=tl(cs)) {
141 alts = cons(mkAltEq(tycon(t).line,
142 makeDPats2(hd(cs),userArity(hd(cs)))),
145 if (cfunOf(hd(tycon(t).defn))!=0) {
146 alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
147 pair(mkInt(tycon(t).line),nameFalse)),alts);
150 } else { /* special case for tuples */
151 alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
153 return singleton(mkBind("==",alts));
156 static Pair local mkAltEq(line,pats) /* make alt for an equation for == */
157 Int line; /* using patterns in pats for lhs */
158 List pats; { /* arguments */
160 Cell q = hd(tl(pats));
164 e = ap2(nameEq,arg(p),arg(q));
165 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
166 e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
169 return pair(pats,pair(mkInt(line),e));
173 static Pair local mkAltOrd ( Int,List );
175 List deriveOrd(t) /* make binding for derived compare*/
176 Type t; { /* for some TUPLE or DATATYPE t */
178 if (isEnumType(t)) { /* special case for enumerations */
179 Cell u = inventVar();
180 Cell w = inventVar();
182 if (cfunOf(hd(tycon(t).defn))!=0) {
183 implementConToTag(t);
184 rhs = ap2(nameCompare,
185 ap(tycon(t).conToTag,u),
186 ap(tycon(t).conToTag,w));
190 alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
191 } else if (isTycon(t)) { /* deal with type constrs */
192 List cs = tycon(t).defn;
193 for (; hasCfun(cs); cs=tl(cs)) {
194 alts = cons(mkAltOrd(tycon(t).line,
195 makeDPats2(hd(cs),userArity(hd(cs)))),
198 if (cfunOf(hd(tycon(t).defn))!=0) {
199 Cell u = inventVar();
200 Cell w = inventVar();
201 implementConToTag(t);
202 alts = cons(pair(doubleton(u,w),
203 pair(mkInt(tycon(t).line),
205 ap(tycon(t).conToTag,u),
206 ap(tycon(t).conToTag,w)))),
210 } else { /* special case for tuples */
211 alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
213 return singleton(mkBind("compare",alts));
216 static Pair local mkAltOrd(line,pats) /* make alt for eqn for compare */
217 Int line; /* using patterns in pats for lhs */
218 List pats; { /* arguments */
220 Cell q = hd(tl(pats));
224 e = ap2(nameCompare,arg(p),arg(q));
225 for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
226 e = ap3(nameCompAux,arg(p),arg(q),e);
230 return pair(pats,pair(mkInt(line),e));
234 /* --------------------------------------------------------------------------
235 * Deriving Ix and Enum:
236 * ------------------------------------------------------------------------*/
238 List deriveEnum(t) /* Construct definition of enumeration */
240 Int l = tycon(t).line;
241 Cell x = inventVar();
242 Cell y = inventVar();
243 Cell first = hd(tycon(t).defn);
244 Cell last = tycon(t).defn;
246 if (!isEnumType(t)) {
247 ERRMSG(l) "Can only derive instances of Enum for enumeration types"
250 while (hasCfun(tl(last))) {
254 implementConToTag(t);
255 implementTagToCon(t);
256 return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
257 cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
262 static List local mkIxBindsEnum ( Tycon );
263 static List local mkIxBinds ( Int,Cell,Int );
264 static Cell local prodRange ( Int,List,Cell,Cell,Cell );
265 static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
266 static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
268 List deriveIx(t) /* Construct definition of indexing */
270 if (isEnumType(t)) { /* Definitions for enumerations */
271 implementConToTag(t);
272 implementTagToCon(t);
273 return mkIxBindsEnum(t);
274 } else if (isTuple(t)) { /* Definitions for product types */
275 return mkIxBinds(0,t,tupleOf(t));
276 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
277 return mkIxBinds(tycon(t).line,
279 userArity(hd(tycon(t).defn)));
281 ERRMSG(tycon(t).line)
282 "Can only derive instances of Ix for enumeration or product types"
284 return NIL;/* NOTREACHED*/
287 /* instance Ix T where
288 * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
290 * | inRange b ci = conToTag ci - conToTag c1
291 * | otherwise = error "Ix.index.T: Index out of range."
292 * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
293 * where i = conToTag ci
295 static List local mkIxBindsEnum(t)
297 Int l = tycon(t).line;
298 Name tagToCon = tycon(t).tagToCon;
299 Name conToTag = tycon(t).conToTag;
300 Cell b = inventVar();
301 Cell c1 = inventVar();
302 Cell c2 = inventVar();
303 Cell ci = inventVar();
304 return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
305 c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon,
306 ap2(nameFromTo,ap(conToTag,c1),
307 ap(conToTag,c2))))))),
308 cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
309 ap2(mkTuple(2),c1,c2))),ci),
310 pair(mkInt(l),ap(COND,
311 triple(ap2(nameInRange,b,ci),
312 ap2(nameMinus,ap(conToTag,ci),
314 ap(nameError,mkStr(findText(
315 "Ix.index: Index out of range"))))))))),
316 cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
317 c1,c2),ci), pair(mkInt(l),ap2(nameAnd,
318 ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
319 ap2(nameLe,ap(conToTag,ci),
320 ap(conToTag,c2))))))),
321 /* ToDo: share conToTag ci */
325 static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
326 Int line; /* a product type */
329 List vs = getDiVars(3*n);
339 for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
340 ls = ap(ls,hd(vs)); /* of the datatype concerned */
341 us = ap(us,hd(vs=tl(vs)));
342 is = ap(is,hd(vs=tl(vs)));
343 js = ap(js,hd(vs)); /* ... and one expression */
345 pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
346 pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
348 return cons(prodRange(line,singleton(pr),ls,us,js),
349 cons(prodIndex(line,pats,ls,us,is),
350 cons(prodInRange(line,pats,ls,us,is),
354 static Cell local prodRange(line,pats,ls,us,is)
355 Int line; /* Make definition of range for a */
356 List pats; /* product type */
358 /* range :: (a,a) -> [a]
359 * range (X a b c, X p q r)
360 * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
364 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
365 e = cons(ap(FROMQUAL,pair(arg(is),
366 ap(nameRange,ap2(mkTuple(2),
370 e = ap(COMP,pair(is1,e));
371 e = singleton(pair(pats,pair(mkInt(line),e)));
372 return mkBind("range",e);
375 static Cell local prodIndex(line,pats,ls,us,is)
376 Int line; /* Make definition of index for a */
377 List pats; /* product type */
379 /* index :: (a,a) -> a -> Bool
380 * index (X a b c, X p q r) (X x y z)
381 * = index (c,r) z + rangeSize (c,r) * (
382 * index (b,q) y + rangeSize (b,q) * (
387 for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
388 xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
390 for (e=hd(xs); nonNull(xs=tl(xs));) {
392 e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
394 e = singleton(pair(pats,pair(mkInt(line),e)));
395 return mkBind("index",e);
398 static Cell local prodInRange(line,pats,ls,us,is)
399 Int line; /* Make definition of inRange for a*/
400 List pats; /* product type */
402 /* inRange :: (a,a) -> a -> Bool
403 * inRange (X a b c, X p q r) (X x y z)
404 * = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
406 Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
407 while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
409 ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
412 e = singleton(pair(pats,pair(mkInt(line),e)));
413 return mkBind("inRange",e);
417 /* --------------------------------------------------------------------------
419 * ------------------------------------------------------------------------*/
421 List deriveShow(t) /* Construct definition of text conversion */
424 if (isTycon(t)) { /* deal with type constrs */
425 List cs = tycon(t).defn;
426 for (; hasCfun(cs); cs=tl(cs)) {
427 alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
431 } else { /* special case for tuples */
432 alts = singleton(mkAltShow(0,t,tupleOf(t)));
434 return singleton(mkBind("showsPrec",alts));
437 static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
441 List vs = getDiVars(a+1);
446 for (vs=tl(vs); i<a; i++) {
447 pat = ap(pat,hd(vs));
450 pats = cons(d,cons(pat,NIL));
451 return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
454 #define shows0 ap(nameShowsPrec,mkInt(0))
455 #define shows10 ap(nameShowsPrec,mkInt(10))
456 #define showsOP ap(nameComp,consChar('('))
457 #define showsOB ap(nameComp,consChar('{'))
458 #define showsCM ap(nameComp,consChar(','))
459 #define showsSP ap(nameComp,consChar(' '))
460 #define showsBQ ap(nameComp,consChar('`'))
461 #define showsCP consChar(')')
462 #define showsCB consChar('}')
464 static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
465 Cell d, pat; /* given pattern, pat */
467 Cell h = getHead(pat);
468 List cfs = cfunSfuns;
471 /* To display a tuple:
472 * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
473 * showChar ',' . showsPrec 0 b .
474 * showChar ',' . showsPrec 0 c .
475 * showChar ',' . showsPrec 0 d .
481 rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
484 return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
487 for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
490 /* To display a value using record syntax:
491 * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
492 * showField "x" e . showChar ',' .
493 * showField "y" f . showChar ',' .
494 * showField "z" g . showChar '}'
496 * = showString lab . showChar '=' . shows val
499 List vs = dupOnto(snd(hd(cfs)),NIL);
504 mkStr(textOf(hd(vs))),
510 rhs = ap(showsCM,rhs);
516 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
520 /* To display a nullary constructor:
521 * showsPrec d Foo = showString "Foo"
523 return ap(nameApp,mkStr(name(h).text));
525 Syntax s = syntaxOf(h);
526 if (a==2 && assocOf(s)!=APPLIC) {
527 /* For a binary constructor with prec p:
528 * showsPrec d (a :* b) = showParen (d > p)
529 * (showsPrec lp a . showChar ' ' .
530 * showsString s . showChar ' ' .
534 Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
535 Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
536 Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
537 if (defaultSyntax(name(h).text)==APPLIC) {
540 ap(nameApp,mkStr(fixLitText(name(h).text))),
544 ap(nameApp,mkStr(fixLitText(name(h).text))),rhs);
548 ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
550 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
554 /* To display a non-nullary constructor with applicative syntax:
555 * showsPrec d (Foo x y) = showParen (d>=10)
556 * (showString "Foo" .
557 * showChar ' ' . showsPrec 10 x .
558 * showChar ' ' . showsPrec 10 y)
560 Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
561 for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
562 rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
564 rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
565 rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
580 /* --------------------------------------------------------------------------
582 * ------------------------------------------------------------------------*/
584 #define Tuple2(f,s) ap2(mkTuple(2),f,s)
585 #define Lex(r) ap(nameLex,r)
586 #define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
587 #define ReadsPrec(n,e) ap2(nameReadsPrec,n,e)
588 #define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
589 #define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
590 #define ReadField(f,s) ap2(nameReadField,f,s)
591 #define GT(l,r) ap2(nameGt,l,r)
592 #define Append(a,b) ap2(nameApp,a,b)
594 /* Construct the readsPrec function of the form:
596 * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
597 * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
599 * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
601 List deriveRead(t) /* construct definition of text reader */
605 Cell d = inventVar();
606 Cell r = inventVar();
607 List pat = cons(d,cons(r,NIL));
611 List cs = tycon(t).defn;
613 for (; hasCfun(cs); cs=tl(cs)) {
614 exps = cons(mkReadCon(hd(cs),d,r),exps);
616 /* reverse concatenate list of subexpressions */
618 for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
619 exp = ap2(nameApp,hd(exps),exp);
621 line = tycon(t).line;
624 exp = ap(mkReadTuple(t),r);
626 /* printExp(stdout,exp); putc('\n',stdout); */
627 alt = pair(pat,pair(mkInt(line),exp));
628 return singleton(mkBind("readsPrec",singleton(alt)));
631 /* Generate an expression of the form:
633 * readParen (d > p) <derived expression> r
635 * for a (non-tuple) constructor "con" of precedence "p".
638 static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
644 Syntax s = syntaxOf(con);
645 List cfs = cfunSfuns;
646 for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
649 exp = mkReadRecord(con,snd(hd(cfs)));
650 return ReadParen(nameFalse, exp, r);
653 if (userArity(con)==2 && assocOf(s)!=APPLIC) {
654 exp = mkReadInfix(con);
657 exp = mkReadPrefix(con);
660 return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
663 /* Given an n-ary prefix constructor, generate a single lambda
664 * expression, such that
666 * data T ... = Constr a1 a2 .. an | ....
670 * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
671 * (t1,s1) <- readsPrec 10 s0,
672 * (t2,s2) <- readsPrec 10 s1,
674 * (tn,sn) <- readsPrec 10 sn-1 ]
677 static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
679 Int arity = userArity(con);
680 Cell cn = mkStr(name(con).text);
681 Cell r = inventVar();
682 Cell prev_s = inventVar();
687 /* build (reversed) list of qualifiers and constructor */
688 quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
689 for(i=0; i<arity; i++) {
690 Cell t = inventVar();
691 Cell s = inventVar();
692 quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
697 /* \r -> [ (exp, prev_s) | quals ] */
698 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
701 /* Given a binary infix constructor of precedence p
703 * ... | T1 `con` T2 | ...
705 * generate the lambda expression
707 * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
708 * ("con",s1) <- lex s0,
709 * (v,s2) <- readsPrec rp s1 ]
711 * where lp and rp are either p or p+1 depending on associativity
713 static Cell local mkReadInfix( con )
716 Syntax s = syntaxOf(con);
718 Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
719 Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
720 Cell cn = mkStr(name(con).text);
721 Cell r = inventVar();
722 Cell s0 = inventVar();
723 Cell s1 = inventVar();
724 Cell s2 = inventVar();
725 Cell u = inventVar();
726 Cell v = inventVar();
729 quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
730 quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
731 quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
733 return Lambda(singleton(r),
734 ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
737 /* Given the n-ary tuple constructor return a lambda expression:
739 * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
740 * (t1, s1) <- readsPrec 0 s0,
742 * (",",s(2n-1)) <- lex s(2n-2),
743 * (tn, s(2n)) <- readsPrec 0 s(2n-1),
744 * (")",s(2n+1)) <- lex s(2n) ]
746 static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
748 Int arity = tupleOf(tup);
749 Cell lp = mkStr(findText("("));
750 Cell rp = mkStr(findText(")"));
751 Cell co = mkStr(findText(","));
753 Cell r = inventVar();
755 Cell s = inventVar();
760 /* build (reversed) list of qualifiers and constructor */
761 for(i=0; i<arity; i++) {
762 Cell t = inventVar();
763 Cell si = inventVar();
764 Cell sj = inventVar();
765 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
766 quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
771 quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
773 /* \ r -> [ (exp,s) | quals ] */
774 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
777 /* Given a record constructor
779 * ... | C { f1 :: T1, ... fn :: Tn } | ...
781 * generate the expression:
783 * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
784 * ("{", s1) <- lex s0,
785 * (t1, s2) <- readField "f1" s1,
787 * (",", s(2n-1)) <- lex s(2n),
788 * (tn, s(2n)) <- readField "fn" s(2n+1),
789 * ("}", s(2n+1)) <- lex s(2n+2) ]
793 * readField :: Read a => String -> ReadS a
794 * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
795 * ("=",s2) <- lex s1,
796 * r <- readsPrec 10 s2 ]
798 static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
801 Cell cn = mkStr(name(con).text);
802 Cell lb = mkStr(findText("{"));
803 Cell rb = mkStr(findText("}"));
804 Cell co = mkStr(findText(","));
806 Cell r = inventVar();
807 Cell s0 = inventVar();
809 Cell s = inventVar();
813 /* build (reversed) list of qualifiers and constructor */
814 quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
815 for(; nonNull(fs); fs=tl(fs)) {
816 Cell f = mkStr(textOf(hd(fs)));
817 Cell t = inventVar();
818 Cell si = inventVar();
819 Cell sj = inventVar();
820 quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
821 quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
826 quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
828 /* \ r -> [ (exp,s) | quals ] */
829 return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
842 /* --------------------------------------------------------------------------
844 * ------------------------------------------------------------------------*/
846 List deriveBounded(t) /* construct definition of bounds */
849 Cell last = tycon(t).defn;
850 Cell first = hd(last);
851 while (hasCfun(tl(last))) {
854 return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
855 cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
857 } else if (isTuple(t)) { /* Definitions for product types */
858 return mkBndBinds(0,t,tupleOf(t));
859 } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
860 return mkBndBinds(tycon(t).line,
862 userArity(hd(tycon(t).defn)));
864 ERRMSG(tycon(t).line)
865 "Can only derive instances of Bounded for enumeration and product types"
870 static List local mkBndBinds(line,h,n) /* build bindings for derived */
871 Int line; /* Bounded on a product type */
877 minB = ap(minB,nameMinBnd);
878 maxB = ap(maxB,nameMaxBnd);
880 return cons(mkBind("minBound",mkVarAlts(line,minB)),
881 cons(mkBind("maxBound",mkVarAlts(line,maxB)),
886 /* --------------------------------------------------------------------------
887 * Helpers: conToTag and tagToCon
888 * ------------------------------------------------------------------------*/
890 /* \ v -> case v of { ...; Ci _ _ -> i; ... } */
891 Void implementConToTag(t)
893 if (isNull(tycon(t).conToTag)) {
894 List cs = tycon(t).defn;
895 Name nm = newName(inventText(),NIL);
896 StgVar v = mkStgVar(NIL,NIL);
897 List alts = NIL; /* can't fail */
899 assert(isTycon(t) && (tycon(t).what==DATATYPE
900 || tycon(t).what==NEWTYPE));
901 for (; hasCfun(cs); cs=tl(cs)) {
903 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
904 StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
906 StgExpr tag = mkStgLet(singleton(r),r);
909 for(i=0; i < name(c).arity; ++i) {
910 vs = cons(mkStgVar(NIL,NIL),vs);
912 alts = cons(mkStgCaseAlt(c,vs,tag),alts);
915 name(nm).line = tycon(t).line;
916 name(nm).type = conToTagType(t);
918 name(nm).closure = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
920 tycon(t).conToTag = nm;
921 addToCodeList ( currentModule, nm );
925 /* \ v -> case v of { ...; i -> Ci; ... } */
926 Void implementTagToCon(t)
928 if (isNull(tycon(t).tagToCon)) {
942 assert(nameUnpackString);
944 assert(isTycon(t) && (tycon(t).what==DATATYPE
945 || tycon(t).what==NEWTYPE));
947 tyconname = textToStr(tycon(t).text);
948 if (strlen(tyconname) > 100)
949 internal("implementTagToCon: tycon name too long");
952 "out-of-range arg for `toEnum' "
953 "in derived `instance Enum %s'",
957 nm = newName(inventText(),NIL);
958 v1 = mkStgVar(NIL,NIL);
959 v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
961 txt0 = mkStr(findText(etxt));
962 bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
963 bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
964 bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
969 mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
971 makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
975 for (; hasCfun(cs); cs=tl(cs)) {
977 Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
978 StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
979 assert(name(c).arity==0);
980 alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
983 name(nm).line = tycon(t).line;
984 name(nm).type = tagToConType(t);
986 name(nm).closure = mkStgVar(
995 mkStgPrimCase(v2,alts))))),
998 tycon(t).tagToCon = nm;
999 addToCodeList ( currentModule, nm );
1004 /* --------------------------------------------------------------------------
1005 * Derivation control:
1006 * ------------------------------------------------------------------------*/
1008 Void deriveControl(what)
1023 case POSTPREL: break;
1027 /*-------------------------------------------------------------------------*/