[project @ 1999-03-15 15:11:03 by simonpj]

Make clear in HsType whether a for-all is explicit
in the source program or not.  Implicit for-alls now
look like
	HsForAllTy Nothing ctxt ty
while explicit ones look like
	HsForAllTy (Just tvs) ctxt ty

Before this, the scope analysis stuff in RnSource was
actually wrong (not that anyone had noticed), but Alex Ferguson
did notice a bogus (sort-of-duplicate) error message on types
like
	f :: Eq a => Int -> Int
which led me to spot the deeper problem.  Anyway, it's all
cool now.

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 3f7237e..74e39e1 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -37,7 +37,7 @@ type ClassAssertion name = (name, [HsType name])
        -- doesn't have to be when reading interface files
 
 data HsType name
-  = HsForAllTy         [HsTyVar name]
+  = HsForAllTy         (Maybe [HsTyVar name])  -- Nothing for implicitly quantified signatures
                        (Context name)
                        (HsType name)
 
@@ -59,7 +59,7 @@ data HsType name
                        [HsType name]
 
 mkHsForAllTy []  []   ty = ty
-mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
+mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
 
 data HsTyVar name
   = UserTyVar name
@@ -120,9 +120,13 @@ pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 pprHsType ty       = ppr_mono_ty pREC_TOP ty
 pprParendHsType ty = ppr_mono_ty pREC_CON ty
 
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
+ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
   = maybeParen (ctxt_prec >= pREC_FUN) $
     sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
+  where
+    tvs = case maybe_tvs of
+               Just tvs -> tvs
+               Nothing  -> []
 
 ppr_mono_ty ctxt_prec (MonoTyVar name)
   = ppr name
@@ -179,8 +183,8 @@ cmpHsTypes cmp tys1 [] = GT
 cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
 
 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
-    cmpContext cmp c1 c2               `thenCmp`
+  = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2      `thenCmp`
+    cmpContext cmp c1 c2                               `thenCmp`
     cmpHsType cmp t1 t2
 
 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
@@ -221,4 +225,10 @@ cmpContext cmp a b
   where
     cmp_ctxt (c1, tys1) (c2, tys2)
       = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+
+-- Should be in Maybes, I guess
+cmpMaybe cmp Nothing  Nothing  = EQ
+cmpMaybe cmp Nothing  (Just x) = LT
+cmpMaybe cmp (Just x)  Nothing = GT
+cmpMaybe cmp (Just x) (Just y) = x `cmp` y
 \end{code}

diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 37984e8..4e4b317 100644 (file)
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -507,7 +507,7 @@ instd       :  instkey inst_type maybe_where        { $$ = mkibind($2,$3,startlineno); }
 /* Compare polytype */
 /* [July 98: first production was tautype DARROW tautype, but I can't see why.] */
 inst_type : apptype DARROW apptype             { is_context_format( $3, 0 );   /* Check the instance head */
-                                                 $$ = mkforall(Lnil,type2context($1),$3); }
+                                                 $$ = mkimp_forall(type2context($1),$3); }
          | apptype                             { is_context_format( $1, 0 );   /* Check the instance head */
                                                  $$ = $1; }
          ;
@@ -705,7 +705,7 @@ polyatype : atype
 polytype : FORALL tyvars1 DOT
                   apptype DARROW tautype       { $$ = mkforall($2,   type2context($4), $6); }
          | FORALL tyvars1 DOT tautype           { $$ = mkforall($2,   Lnil,             $4); }
-         |        apptype DARROW tautype       { $$ = mkforall(Lnil, type2context($1), $3); }
+         |        apptype DARROW tautype       { $$ = mkimp_forall(  type2context($1), $3); }
          | tautype
         ;
 

diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn
index d89ee20..1058a99 100644 (file)
--- a/ghc/compiler/parser/ttype.ugn
+++ b/ghc/compiler/parser/ttype.ugn
@@ -25,5 +25,7 @@ type ttype;
        forall  : < gtforalltv  : list;         /* tyvars */
                    gtforallctxt : list;        /* theta */
                    gtforallt   : ttype; >;
+       imp_forall : < gtiforallctxt : list ;   /* Implicit forall; no explicit tyvars */
+                      gtiforallt    : ttype; >;
 end;
 

diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 452e2a5..8091b74 100644 (file)
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -115,17 +115,18 @@ extract_ctxt ctxt acc = foldr extract_ass acc ctxt
                      where
                        extract_ass (cls, tys) acc = foldr extract_ty acc tys
 
-extract_ty (MonoTyApp ty1 ty2)     acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty)         acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _)      acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2)     acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoDictTy cls tys)            acc = foldr extract_ty acc tys
-extract_ty (MonoTyVar tv)           acc = insertTV tv acc
-extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
-                                         (filter (`notElem` locals) $
-                                          extract_ctxt ctxt (extract_ty ty []))
-                                       where
-                                         locals = map getTyVarName tvs
+extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoListTy ty)     acc = extract_ty ty acc
+extract_ty (MonoTupleTy tys _)  acc = foldr extract_ty acc tys
+extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (MonoDictTy cls tys)        acc = foldr extract_ty acc tys
+extract_ty (MonoTyVar tv)       acc = insertTV tv acc
+extract_ty (HsForAllTy (Just tvs) ctxt ty) 
+                               acc = acc ++
+                                     (filter (`notElem` locals) $
+                                      extract_ctxt ctxt (extract_ty ty []))
+                                   where
+                                     locals = map getTyVarName tvs
 
 insertTV name   acc | isRdrTyVar name = name : acc
 insertTV other  acc                  = acc

diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 9c68e07..edd0039 100644 (file)
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -739,16 +739,21 @@ wlkHsSigType ttype
        -- make sure it starts with a ForAll
     case ty of
        HsForAllTy _ _ _ -> returnUgn ty
-       other            -> returnUgn (HsForAllTy [] [] ty)
+       other            -> returnUgn (HsForAllTy Nothing [] ty)
 
 wlkHsType :: U_ttype -> UgnM RdrNameHsType
 wlkHsType ttype
   = case ttype of
-      U_forall u_tyvars u_theta u_ty -> -- context
+      U_forall u_tyvars u_theta u_ty -> -- Explicit forall
        wlkList rdTvId u_tyvars         `thenUgn` \ tyvars -> 
        wlkContext u_theta              `thenUgn` \ theta ->
        wlkHsType u_ty                  `thenUgn` \ ty   ->
-       returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty)
+       returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty)
+
+      U_imp_forall u_theta u_ty ->     -- Implicit forall
+       wlkContext u_theta              `thenUgn` \ theta ->
+       wlkHsType u_ty                  `thenUgn` \ ty   ->
+       returnUgn (HsForAllTy Nothing theta ty)
 
       U_namedtvar tv -> -- type variable
        wlkTvId tv      `thenUgn` \ tyvar ->
@@ -786,11 +791,16 @@ wlkInstType ttype
        wlkList rdTvId u_tyvars         `thenUgn` \ tyvars -> 
        wlkContext  u_theta             `thenUgn` \ theta ->
        wlkClsTys inst_head             `thenUgn` \ (clas, tys)  ->
-       returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys))
+       returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys))
+
+      U_imp_forall u_theta inst_head ->
+       wlkContext  u_theta             `thenUgn` \ theta ->
+       wlkClsTys inst_head             `thenUgn` \ (clas, tys)  ->
+       returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys))
 
       other -> -- something else
        wlkClsTys other   `thenUgn` \ (clas, tys) ->
-       returnUgn (HsForAllTy [] [] (MonoDictTy clas tys))
+       returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys))
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index d723fd4..29abb3b 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -81,9 +81,11 @@ extractHsTyNames ty
     get (MonoFunTy ty1 ty2)      = get ty1 `unionNameSets` get ty2
     get (MonoDictTy cls tys)     = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
     get (MonoTyVar tv)          = unitNameSet tv
-    get (HsForAllTy tvs ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
+    get (HsForAllTy (Just tvs) 
+                   ctxt ty)     = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
                                            `minusNameSet`
                                    mkNameSet (map getTyVarName tvs)
+    get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
 
 extractHsTyNames_s  :: [RenamedHsType] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 1fd4d95..1dddb22 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -51,7 +51,7 @@ import Bag            ( bagToList )
 import Outputable
 import SrcLoc          ( SrcLoc )
 import UniqFM          ( lookupUFM )
-import Maybes          ( maybeToBool )
+import Maybes          ( maybeToBool, catMaybes )
 import Util
 \end{code}
 
@@ -271,8 +271,8 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
     rnHsSigType (text "an instance decl") inst_ty      `thenRn` \ (inst_ty', inst_fvs) ->
     let
        inst_tyvars = case inst_ty' of
-                       HsForAllTy inst_tyvars _ _ -> inst_tyvars
-                       other                      -> []
+                       HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
+                       other                             -> []
        -- (Slightly strangely) the forall-d tyvars scope over
        -- the method bindings too
     in
@@ -495,59 +495,59 @@ rnIfaceType doc ty
  = rnHsType doc ty     `thenRn` \ (ty,_) ->
    returnRn ty
 
+
+rnForAll doc forall_tyvars ctxt ty
+  = bindTyVarsFVRn doc forall_tyvars                   $ \ new_tyvars ->
+    rnContext doc ctxt                                 `thenRn` \ (new_ctxt, cxt_fvs) ->
+    rnHsType doc ty                                    `thenRn` \ (new_ty, ty_fvs) ->
+    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
+             cxt_fvs `plusFV` ty_fvs)
+
+-- Check that each constraint mentions at least one of the forall'd type variables
+-- Since the forall'd type variables are a subset of the free tyvars
+-- of the tau-type part, this guarantees that every constraint mentions
+-- at least one of the free tyvars in ty
+checkConstraints explicit_forall doc forall_tyvars ctxt ty
+   = mapRn check ctxt                  `thenRn` \ maybe_ctxt' ->
+     returnRn (catMaybes maybe_ctxt')
+           -- Remove problem ones, to avoid duplicate error message.
+   where
+     check ct@(_,tys)
+       | forall_mentioned = returnRn (Just ct)
+       | otherwise        = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
+                            returnRn Nothing
+        where
+         forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyVars)
+                            False
+                            tys
+
+
 rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
 
-rnHsType doc (HsForAllTy [] ctxt ty)
+rnHsType doc (HsForAllTy Nothing ctxt ty)
        -- From source code (no kinds on tyvars)
-
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
-       -- 
-       -- We insist that the universally quantified type vars is a superset of FV(C)
-       -- It follows that FV(T) is a superset of FV(C), so that the context constrains
-       -- no type variables that don't appear free in the tau-type part.
-
   = getLocalNameEnv            `thenRn` \ name_env ->
     let
        mentioned_tyvars = extractHsTyVars ty
        forall_tyvars    = filter (not . (`elemFM` name_env)) mentioned_tyvars
-
-       ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
-       ctxt_w_ftvs  = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
-                      | constraint@(_,tys) <- ctxt]
-
-       -- A 'non-poly constraint' is one that does not mention *any*
-       -- of the forall'd type variables
-       non_poly_constraints = filter non_poly ctxt_w_ftvs
-       non_poly (c,ftvs)    = not (any (`elem` forall_tyvars) ftvs)
-
-       -- A 'non-mentioned' constraint is one that mentions a
-       -- type variable that does not appear in 'ty'
-       non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
-       non_mentioned (c,ftvs)    = any (not . (`elem` mentioned_tyvars)) ftvs
-
-       -- Zap the context if there's a problem, to avoid duplicate error message.
-       ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
-             | otherwise = []
     in
-    mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints         `thenRn_`
-    mapRn (ctxtErr2 doc ty)               non_mentioned_constraints    `thenRn_`
-
-    (bindTyVarsFVRn doc (map UserTyVar forall_tyvars)  $ \ new_tyvars ->
-    rnContext doc ctxt'                                        `thenRn` \ (new_ctxt, cxt_fvs) ->
-    rnHsType doc ty                                    `thenRn` \ (new_ty, ty_fvs) ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
-             cxt_fvs `plusFV` ty_fvs)
-    )
-
-rnHsType doc (HsForAllTy tvs ctxt ty)
-       -- tvs are non-empty, hence must be from an interface file
-       --      (tyvars may be kinded)
-  = bindTyVarsFVRn doc tvs             $ \ new_tyvars ->
-    rnContext doc ctxt                 `thenRn` \ (new_ctxt, cxt_fvs) ->
-    rnHsType doc ty                    `thenRn` \ (new_ty, ty_fvs) ->
-    returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
-             cxt_fvs `plusFV` ty_fvs)
+    checkConstraints False doc forall_tyvars ctxt ty   `thenRn` \ ctxt' ->
+    rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
+
+rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
+       -- Explicit quantification.
+       -- Check that the forall'd tyvars are a subset of the
+       -- free tyvars in the tau-type part
+  = let
+       mentioned_tyvars   = extractHsTyVars ty
+       bad_guys           = filter (`notElem` mentioned_tyvars) forall_tyvar_names
+       forall_tyvar_names = map getTyVarName forall_tyvars
+    in
+    mapRn (forAllErr doc ty) bad_guys                          `thenRn_`
+    checkConstraints True doc forall_tyvar_names ctxt ty       `thenRn` \ ctxt' ->
+    rnForAll doc forall_tyvars ctxt' ty
 
 rnHsType doc (MonoTyVar tyvar)
   = lookupOccRn tyvar          `thenRn` \ tyvar' ->
@@ -791,23 +791,21 @@ dupClassAssertWarn ctxt (assertion : dups)
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
-ctxtErr1 doc tyvars ty (constraint, _)
+forAllErr doc ty tyvar
   = addErrRn (
-      sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
-                  ptext SLIT("does not mention any of"),
-          nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
-          nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
-      ]
+      sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+          nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
       $$
-      (ptext SLIT("In") <+> doc)
-    )
+      (ptext SLIT("In") <+> doc))
 
-ctxtErr2 doc ty (constraint,_)
-  = addErrRn (
-       sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
-       nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
-       nest 4 (quotes (ppr ty))]
-        $$
-       (ptext SLIT("In") <+> doc)
-    )
+ctxtErr explicit_forall doc tyvars constraint ty
+  = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
+                  ptext SLIT("does not mention any of"),
+        if explicit_forall then
+          nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
+        else
+          nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
+    ]
+    $$
+    (ptext SLIT("In") <+> doc)
 \end{code}

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index d7bd21c..6eb256d 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -152,7 +152,7 @@ tc_type_kind (MonoDictTy class_name tys)
   = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
     returnTc (boxedTypeKind, mkDictTy clas arg_tys)
 
-tc_type_kind (HsForAllTy tv_names context ty)
+tc_type_kind (HsForAllTy (Just tv_names) context ty)
   = tcExtendTyVarScope tv_names                $ \ tyvars -> 
     tcContext context                  `thenTc` \ theta ->
     tc_boxed_type ty                   `thenTc` \ tau ->