Commit 236156d9 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-01-05 18:05:33 by sewardj]

Fix more interface-reading bugs:
-- Qualtypes were not being generated from DICTAPs for overloaded
   non-class values.  New function dictapsToQualtype to handle this.
-- Incorrect construction of constructor result type in startGHCDataDecl
   for parameterised types eg   Just :: a -> Maybe a.

Changed meaning of DICTAP, so that the construction is
  ap(DICTAP, (QConId, Type))  rather than
  ap(DICTAP, (QConId, [Type])).  Will have to undo this if we want
                                 to support multiparam type classes.
parent 0d5db29b
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.30 $
* $Date: 1999/12/10 15:59:44 $
* $Revision: 1.31 $
* $Date: 2000/01/05 18:05:33 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -1815,7 +1815,7 @@ Text t; {
} else {
Printf("<unknown type>");
}
printf("\n");print(name(nm).type,10);printf("\n");
if (isCfun(nm)) {
Printf(" -- data constructor");
} else if (isMfun(nm)) {
......
......@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
* $Revision: 1.16 $
* $Date: 2000/01/05 15:57:40 $
* $Revision: 1.17 $
* $Date: 2000/01/05 18:05:33 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -1267,6 +1267,52 @@ Void finishGHCImports ( ConId nm, List syms )
* Vars (values)
* ------------------------------------------------------------------------*/
/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
{ C1 a } -> { C2 b } -> T into
ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
*/
static Type dictapsToQualtype ( Type ty )
{
List pieces = NIL;
List preds, dictaps;
/* break ty into pieces at the top-level arrows */
while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
pieces = cons ( arg(fun(ty)), pieces );
ty = arg(ty);
}
pieces = cons ( ty, pieces );
pieces = reverse ( pieces );
dictaps = NIL;
while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
dictaps = cons ( hd(pieces), dictaps );
pieces = tl(pieces);
}
/* dictaps holds the predicates, backwards */
/* pieces holds the remainder of the type, forwards */
assert(nonNull(pieces));
pieces = reverse(pieces);
ty = hd(pieces);
pieces = tl(pieces);
for (; nonNull(pieces); pieces=tl(pieces))
ty = fn(hd(pieces),ty);
preds = NIL;
for (; nonNull(dictaps); dictaps=tl(dictaps)) {
Cell da = hd(dictaps);
QualId cl = fst(unap(DICTAP,da));
Cell arg = snd(unap(DICTAP,da));
preds = cons ( pair(cl,arg), preds );
}
if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
return ty;
}
void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
......@@ -1284,6 +1330,12 @@ void startGHCValue ( Int line, VarId vid, Type ty )
}
n = newName(v,NIL);
/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
{ C1 a } -> { C2 b } -> T into
ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
*/
ty = dictapsToQualtype(ty);
tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
hd(tmp) = zpair(hd(tmp),STAR);
......@@ -1407,7 +1459,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
/* make resTy the result type of the constr, T v1 ... vn */
resTy = tycon;
for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
resTy = ap(resTy,fst(hd(tmp)));
resTy = ap(resTy,zfst(hd(tmp)));
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
......@@ -2049,7 +2101,7 @@ static Type conidcellsToTycons ( Int line, Type type )
case QUAL:
return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
conidcellsToTycons(line,snd(snd(type)))));
case DICTAP: /* :: ap(DICTAP, pair(Class,[Type]))
case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
Not sure if this is really the right place to
convert it to the form Hugs wants, but will do so anyway.
*/
......@@ -2057,10 +2109,8 @@ static Type conidcellsToTycons ( Int line, Type type )
{
Class cl = fst(unap(DICTAP,type));
List args = snd(unap(DICTAP,type));
if (length(args) != 1)
internal("conidcellsToTycons: DICTAP: multiparam ap");
return
conidcellsToTycons(line,pair(cl,hd(args)));
conidcellsToTycons(line,pair(cl,args));
}
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
......@@ -2109,6 +2159,8 @@ static Bool allTypesKnown ( Type type,
case QUALIDENT:
if (isNull(qualidIsMember(type,aktys))) goto missing;
return TRUE;
case TYCON:
return TRUE;
default:
fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
......
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
* $Revision: 1.23 $
* $Date: 1999/12/20 16:55:27 $
* $Revision: 1.24 $
* $Date: 2000/01/05 18:05:34 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -523,6 +523,11 @@ break;
// = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
// ,1,0,THREADID_REP);
setCurrModule(modulePrelude);
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
2,DATATYPE,NIL);
} else {
modulePrelude = newModule(textPrelude);
......
......@@ -12,8 +12,8 @@
* included in the distribution.
*
* $RCSfile: parser.y,v $
* $Revision: 1.20 $
* $Date: 2000/01/05 13:53:36 $
* $Revision: 1.21 $
* $Date: 2000/01/05 18:05:34 $
* ------------------------------------------------------------------------*/
%{
......@@ -227,9 +227,9 @@ ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */
: ALL ifForall IMPLIES {$$=gc3($2);}
| {$$=gc0(NIL);}
;
ifInstHd /* { Class aType } :: (ConId, Type) */
ifInstHd /* { Class aType } :: ((ConId, Type)) */
: '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
zpair($2,singleton($3))));}
zpair($2,$3)));}
;
ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
......@@ -356,14 +356,11 @@ ifAType : ifQTCName { $$ = gc1($1); }
| '(' ifTypeL2 ')' { $$ = gc3(buildTuple(reverse($2))); }
| '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
$2));}
| '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP,
| '{' ifQTCName ifAType '}' { $$ = gc4(ap(DICTAP,
pair($2,$3))); }
| '(' ifType ')' { $$ = gc3($2); }
| UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); }
;
ifATypes : { $$ = gc0(NIL); }
| ifAType ifATypes { $$ = gc2(cons($1,$2)); }
;
/*- KW's usage stuff --------------------------------------*/
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment