From 236156d9446b20f05e66f4003f0d854adc6ff0d2 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 5 Jan 2000 18:05:34 +0000 Subject: [PATCH] [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. --- ghc/interpreter/hugs.c | 6 ++-- ghc/interpreter/interface.c | 66 ++++++++++++++++++++++++++++++++++++++----- ghc/interpreter/link.c | 9 ++++-- ghc/interpreter/parser.y | 13 ++++----- 4 files changed, 74 insertions(+), 20 deletions(-) diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 3c11292..111f1bc 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -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 @@ -1815,7 +1815,7 @@ Text t; { } else { Printf(""); } - +printf("\n");print(name(nm).type,10);printf("\n"); if (isCfun(nm)) { Printf(" -- data constructor"); } else if (isMfun(nm)) { diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c index 4245ff4..af108f5 100644 --- a/ghc/interpreter/interface.c +++ b/ghc/interpreter/interface.c @@ -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)); diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 8d7ff5d..f151506 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -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); diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 9258670..783a669 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -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 --------------------------------------*/ -- 1.7.10.4