[project @ 2000-02-10 18:39:51 by lewie]

[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index cb8861d..26e6dee 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -11,7 +11,7 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) w
 import RnExpr
 import HsSyn
 import HsPragmas
 import RnExpr
 import HsSyn
 import HsPragmas

-import HsTypes         ( getTyVarName, pprClassAssertion, cmpHsTypes )
+import HsTypes         ( getTyVarName, pprHsPred, cmpHsTypes )

 import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
                          extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
 import RdrName         ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
 import RdrHsSyn                ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
                          extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars

@@ -20,7 +20,7 @@ import RnHsSyn
 import HsCore
 
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
 import HsCore
 
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )

-import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, 
+import RnEnv           ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,

                          lookupImplicitOccRn, 
                          bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
                          lookupImplicitOccRn, 
                          bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
                          bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,

@@ -32,6 +32,8 @@ import RnEnv          ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
                        )
 import RnMonad
 
                        )
 import RnMonad
 

+import FunDeps         ( oclose )
+

 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)
 import Name            ( Name, OccName,
                          ExportFlag(..), Provenance(..), 
                          nameOccName, NamedThing(..)

@@ -61,6 +63,8 @@ It also does the following error checks:
 \item
 Checks that tyvars are used properly. This includes checking
 for undefined tyvars, and tyvars in contexts that are ambiguous.
 \item
 Checks that tyvars are used properly. This includes checking
 for undefined tyvars, and tyvars in contexts that are ambiguous.

+(Some of this checking has now been moved to module @TcMonoType@,
+since we don't have functional dependency information at this point.)

 \item
 Checks that all variable occurences are defined.
 \item 
 \item
 Checks that all variable occurences are defined.
 \item 

@@ -158,7 +162,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 

-rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
+rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas

                tname dname snames src_loc))
   = pushSrcLocRn src_loc $
 
                tname dname snames src_loc))
   = pushSrcLocRn src_loc $
 

@@ -181,6 +185,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        -- Check the superclasses
     rnContext cls_doc context                  `thenRn` \ (context', cxt_fvs) ->
 
        -- Check the superclasses
     rnContext cls_doc context                  `thenRn` \ (context', cxt_fvs) ->
 

+       -- Check the functional dependencies
+    rnFds cls_doc fds                  `thenRn` \ (fds', fds_fvs) ->
+

        -- Check the signatures
     let
            -- First process the class op sigs, then the fixity sigs.
        -- Check the signatures
     let
            -- First process the class op sigs, then the fixity sigs.

@@ -188,7 +195,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
          (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
     in
     checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 
          (fix_sigs, non_sigs)   = partition isFixitySig  non_op_sigs
     in
     checkDupOrQualNames sig_doc sig_rdr_names_w_locs   `thenRn_` 

-    mapFvRn (rn_op cname' clas_tyvar_names) op_sigs
+    mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs

     `thenRn` \ (sigs', sig_fvs) ->
     mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
     let
     `thenRn` \ (sigs', sig_fvs) ->
     mapRn_  (unknownSigErr) non_sigs                   `thenRn_`
     let

@@ -208,11 +215,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)
        -- for instance decls.
 
     ASSERT(isNoClassPragmas pragmas)

-    returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds'
+    returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds'

                               NoClassPragmas tname' dname' snames' src_loc),
              sig_fvs   `plusFV`
              fix_fvs   `plusFV`
              cxt_fvs   `plusFV`
                               NoClassPragmas tname' dname' snames' src_loc),
              sig_fvs   `plusFV`
              fix_fvs   `plusFV`
              cxt_fvs   `plusFV`

+             fds_fvs   `plusFV`

              meth_fvs
             )
     )
              meth_fvs
             )
     )

@@ -225,7 +233,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
     meth_rdr_names       = map fst meth_rdr_names_w_locs
 
     meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
     meth_rdr_names       = map fst meth_rdr_names_w_locs
 

-    rn_op clas clas_tyvars sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)
+    rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn)

       = pushSrcLocRn locn $
        lookupBndrRn op                         `thenRn` \ op_name ->
 
       = pushSrcLocRn locn $
        lookupBndrRn op                         `thenRn` \ op_name ->
 

@@ -233,7 +241,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas
        rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
            check_in_op_ty clas_tyvar =
        rnHsSigType (quotes (ppr op)) ty        `thenRn` \ (new_ty, op_ty_fvs)  ->
        let
            check_in_op_ty clas_tyvar =

-                checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
+                checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs)

                         (classTyVarNotInOpTyErr clas_tyvar sig)
        in
         mapRn_ check_in_op_ty clas_tyvars               `thenRn_`
                         (classTyVarNotInOpTyErr clas_tyvar sig)
        in
         mapRn_ check_in_op_ty clas_tyvars               `thenRn_`

@@ -552,9 +560,11 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
        -- context in which case it's an error
   = let
        mentioned_in_tau  = extractHsTyRdrTyVars tau
        -- context in which case it's an error
   = let
        mentioned_in_tau  = extractHsTyRdrTyVars tau

-       mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
-                                     ty <- tys,
+       mentioned_in_ctxt = nub [tv | p <- ctxt,
+                                     ty <- tys_of_pred p,

                                      tv <- extractHsTyRdrTyVars ty]
                                      tv <- extractHsTyRdrTyVars ty]

+       tys_of_pred (HsPClass clas tys) = tys
+       tys_of_pred (HsPIParam n ty) = [ty]

 
        dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
                -- dubious = explicitly quantified but not mentioned in tau type
 
        dubious_guys          = filter (`notElem` mentioned_in_tau) forall_tyvar_names
                -- dubious = explicitly quantified but not mentioned in tau type

@@ -565,7 +575,7 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
  
        forall_tyvar_names    = map getTyVarName forall_tyvars
     in
  
        forall_tyvar_names    = map getTyVarName forall_tyvars
     in

-    mapRn_ (forAllErr doc tau) bad_guys                                        `thenRn_`
+    -- mapRn_ (forAllErr doc tau) bad_guys                                     `thenRn_`

     mapRn_ (forAllWarn doc tau) warn_guys                                      `thenRn_`
     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau  `thenRn` \ ctxt' ->
     rnForAll doc forall_tyvars ctxt' tau
     mapRn_ (forAllWarn doc tau) warn_guys                                      `thenRn_`
     checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau  `thenRn` \ ctxt' ->
     rnForAll doc forall_tyvars ctxt' tau

@@ -578,25 +588,20 @@ rnHsPolyType doc other_ty = rnHsType doc other_ty
 -- of the tau-type part, this guarantees that every constraint mentions
 -- at least one of the free tyvars in ty
 checkConstraints doc forall_tyvars tau_vars ctxt ty
 -- of the tau-type part, this guarantees that every constraint mentions
 -- at least one of the free tyvars in ty
 checkConstraints doc forall_tyvars tau_vars ctxt ty

-   = mapRn check ctxt                  `thenRn` \ maybe_ctxt' ->
+   = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->

      returnRn (catMaybes maybe_ctxt')
            -- Remove problem ones, to avoid duplicate error message.
      returnRn (catMaybes maybe_ctxt')
            -- Remove problem ones, to avoid duplicate error message.

-   where
-     check ct@(_,tys)
-       | ambiguous = failWithRn Nothing (ambigErr doc ct ty)
-       | not_univ  = failWithRn Nothing (univErr  doc ct ty)
-       | otherwise = returnRn (Just ct)
-        where
-         ct_vars    = extractHsTysRdrTyVars tys
-
-         ambiguous  =  -- All the universally-quantified tyvars in the constraint must appear in the tau ty
-                       -- (will change when we get functional dependencies)
-                       not (all (\ct_var -> not (ct_var `elem` forall_tyvars) || ct_var `elem` tau_vars) ct_vars)
-                       
-         not_univ   =  -- At least one of the tyvars in each constraint must
-                       -- be universally quantified. This restriction isn't in Hugs
-                       not (any (`elem` forall_tyvars) ct_vars)

        
        

+checkPred doc forall_tyvars ty p@(HsPClass clas tys)
+  | not_univ  = failWithRn Nothing (univErr  doc p ty)
+  | otherwise = returnRn (Just p)
+  where
+      ct_vars  = extractHsTysRdrTyVars tys
+      not_univ =  -- At least one of the tyvars in each constraint must
+                 -- be universally quantified. This restriction isn't in Hugs
+                 not (any (`elem` forall_tyvars) ct_vars)
+checkPred doc forall_tyvars ty p@(HsPIParam _ _)
+  = returnRn (Just p)

 
 rnForAll doc forall_tyvars ctxt ty
   = bindTyVarsFVRn doc forall_tyvars   $ \ new_tyvars ->
 
 rnForAll doc forall_tyvars ctxt ty
   = bindTyVarsFVRn doc forall_tyvars   $ \ new_tyvars ->

@@ -673,25 +678,43 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 
 rnContext doc ctxt
 rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
 
 rnContext doc ctxt

-  = mapAndUnzipRn rn_ctxt ctxt         `thenRn` \ (theta, fvs_s) ->
+  = mapAndUnzipRn (rnPred doc) ctxt    `thenRn` \ (theta, fvs_s) ->

     let
     let

-       (_, dup_asserts) = removeDups cmp_assert theta
+       (_, dup_asserts) = removeDups (cmpHsPred compare) theta

     in
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
 
     returnRn (theta, plusFVs fvs_s)
     in
        -- Check for duplicate assertions
        -- If this isn't an error, then it ought to be:
     mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts  `thenRn_`
 
     returnRn (theta, plusFVs fvs_s)

-  where
-    rn_ctxt (clas, tys)
-      =        lookupOccRn clas                `thenRn` \ clas_name ->
-       rnHsTypes doc tys               `thenRn` \ (tys', fvs) ->
-       returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)

 
 

-    cmp_assert (c1,tys1) (c2,tys2)
-      = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+rnPred doc (HsPClass clas tys)
+  = lookupOccRn clas           `thenRn` \ clas_name ->
+    rnHsTypes doc tys          `thenRn` \ (tys', fvs) ->
+    returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+rnPred doc (HsPIParam n ty)
+  = getIPName n                        `thenRn` \ name ->
+    rnHsType doc ty            `thenRn` \ (ty', fvs) ->
+    returnRn (HsPIParam name ty', fvs)

 \end{code}
 
 \end{code}
 

+\begin{code}
+rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
+
+rnFds doc fds
+  = mapAndUnzipRn rn_fds fds           `thenRn` \ (theta, fvs_s) ->
+    returnRn (theta, plusFVs fvs_s)
+  where
+    rn_fds (tys1, tys2)
+      =        rnHsTyVars doc tys1             `thenRn` \ (tys1', fvs1) ->
+       rnHsTyVars doc tys2             `thenRn` \ (tys2', fvs2) ->
+       returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
+
+rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar
+  = lookupOccRn tyvar          `thenRn` \ tyvar' ->
+    returnRn (tyvar', unitFV tyvar')
+\end{code}

 
 %*********************************************************
 %*                                                      *
 
 %*********************************************************
 %*                                                      *

@@ -882,9 +905,9 @@ classTyVarNotInOpTyErr clas_tyvar sig
 
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 
 
 dupClassAssertWarn ctxt (assertion : dups)
   = sep [hsep [ptext SLIT("Duplicate class assertion"), 

-              quotes (pprClassAssertion assertion),
+              quotes (pprHsPred assertion),

               ptext SLIT("in the context:")],
               ptext SLIT("in the context:")],

-        nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
+        nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]

 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 
 badDataCon name
    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]

@@ -917,7 +940,7 @@ forAllErr doc ty tyvar
 
 univErr doc constraint ty
   = sep [ptext SLIT("All of the type variable(s) in the constraint")
 
 univErr doc constraint ty
   = sep [ptext SLIT("All of the type variable(s) in the constraint")

-          <+> quotes (pprClassAssertion constraint) 
+          <+> quotes (pprHsPred constraint) 

          <+> ptext SLIT("are already in scope"),
         nest 4 (ptext SLIT("At least one must be universally quantified here"))
     ]
          <+> ptext SLIT("are already in scope"),
         nest 4 (ptext SLIT("At least one must be universally quantified here"))
     ]

@@ -925,7 +948,7 @@ univErr doc constraint ty
     (ptext SLIT("In") <+> doc)
 
 ambigErr doc constraint ty
     (ptext SLIT("In") <+> doc)
 
 ambigErr doc constraint ty

-  = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
+  = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),

         nest 4 (ptext SLIT("in the type:") <+> ppr ty),
         nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
     $$
         nest 4 (ptext SLIT("in the type:") <+> ppr ty),
         nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
     $$