[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.

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 3c11292..111f1bc 100644 (file)
--- 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 <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)) {

diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index 4245ff4..af108f5 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 --------------------------------------*/