Parse and desugar equational constraints

- With -findexed-types, equational constraints can appear in contexts
  wherever class predicates are allowed.
- The two argument types need to be boxed and rank 0.

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f246412..58524ea 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -398,6 +398,7 @@ repPred (HsClassP cls tys) = do
                               tcon <- repTy (HsTyVar cls)
                               tys1 <- repLTys tys
                               repTapps tcon tys1
                               tcon <- repTy (HsTyVar cls)
                               tys1 <- repLTys tys
                               repTapps tcon tys1

+repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)

 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 
 -- yield the representation of a list of types
 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 
 -- yield the representation of a list of types

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 1ec0966..a4ac865 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -102,7 +102,8 @@ type HsContext name = [LHsPred name]
 
 type LHsPred name = Located (HsPred name)
 
 
 type LHsPred name = Located (HsPred name)
 

-data HsPred name = HsClassP name [LHsType name]
+data HsPred name = HsClassP name [LHsType name]                 -- class constraint
+                | HsEqualP (LHsType name) (LHsType name)-- equality constraint

                 | HsIParam (IPName name) (LHsType name)
 
 type LHsType name = Located (HsType name)
                 | HsIParam (IPName name) (LHsType name)
 
 type LHsType name = Located (HsType name)

@@ -268,9 +269,6 @@ splitHsFunType other                   = ([], other)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-NB: these types get printed into interface files, so 
-    don't change the printing format lightly
-

 \begin{code}
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 \begin{code}
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty

@@ -280,8 +278,13 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
 
 instance OutputableBndr name => Outputable (HsPred name) where
     ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
 
 instance OutputableBndr name => Outputable (HsPred name) where

-    ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys)
-    ppr (HsIParam n ty)    = hsep [ppr n, dcolon, ppr ty]
+    ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
+    ppr (HsEqualP t1 t2)    = hsep [pprLHsType t1, ptext SLIT("~"), 
+                                   pprLHsType t2]
+    ppr (HsIParam n ty)     = hsep [ppr n, dcolon, ppr ty]
+
+pprLHsType :: OutputableBndr name => LHsType name -> SDoc
+pprLHsType = pprParendHsType . unLoc

 
 pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
 pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name
 
 pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
 pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f349f30..d35d4e2 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -981,7 +981,8 @@ gentype :: { LHsType RdrName }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  gentype       { LL $ HsOpTy $1 $2 $3 }
         : btype                         { $1 }
         | btype qtyconop gentype        { LL $ HsOpTy $1 $2 $3 }
         | btype tyvarop  gentype       { LL $ HsOpTy $1 $2 $3 }

-       | btype '->' ctype              { LL $ HsFunTy $1 $3 }
+       | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
+        | btype '~'      gentype       { LL $ HsPredTy (HsEqualP $1 $3) }

 
 btype :: { LHsType RdrName }
        : btype atype                   { LL $ HsAppTy $1 $2 }
 
 btype :: { LHsType RdrName }
        : btype atype                   { LL $ HsAppTy $1 $2 }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 03d4c41..200ea57 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -97,8 +97,9 @@ extractHsRhoRdrTyVars ctxt ty
 
 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 
 
 extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
 

-extract_pred (HsClassP cls tys) acc    = foldr extract_lty acc tys
-extract_pred (HsIParam n ty) acc       = extract_lty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
+extract_pred (HsIParam n ty   ) acc = extract_lty ty acc

 
 extract_lty (L loc ty) acc 
   = case ty of
 
 extract_lty (L loc ty) acc 
   = case ty of

@@ -406,6 +407,15 @@ checkInstType (L l t)
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 

+checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
+checkDictTy (L spn ty) = check ty []
+  where
+  check (HsTyVar t) args | not (isRdrTyVar t) 
+       = return (L spn (HsPredTy (HsClassP t args)))
+  check (HsAppTy l r) args = check (unLoc l) (r:args)
+  check (HsParTy t)   args = check (unLoc t) args
+  check _ _ = parseError spn "Malformed instance header"
+

 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a

@@ -477,10 +487,12 @@ checkTyClHdr (L l cxt) ty
     go l other          acc    = 
       parseError l "Malformed head of type or class declaration"
 
     go l other          acc    = 
       parseError l "Malformed head of type or class declaration"
 

-       -- The predicates in a type or class decl must all
-       -- be HsClassPs.  They need not all be type variables,
-       -- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
-    chk_pred (L l (HsClassP _ args)) = return ()
+       -- The predicates in a type or class decl must be class predicates or 
+       -- equational constraints.  They need not all have variable-only
+       -- arguments, even in Haskell 98.  
+       -- E.g. class (Monad m, Monad (t m)) => MonadT t m
+    chk_pred (L l (HsClassP _ _)) = return ()
+    chk_pred (L l (HsEqualP _ _)) = return ()

     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 

@@ -571,22 +583,16 @@ checkPred (L spn ty)
   where
     checkl (L l ty) args = check l ty args
 
   where
     checkl (L l ty) args = check l ty args
 

+    check _loc (HsPredTy pred@(HsEqualP _ _)) 
+                                       args | null args
+                                           = return $ L spn pred

     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
                                            = return (L spn (HsClassP t args))
     check _loc (HsAppTy l r)           args = checkl l (r:args)
     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
     check _loc (HsParTy t)            args = checkl t args
     check _loc (HsTyVar t)             args | not (isRdrTyVar t) 
                                            = return (L spn (HsClassP t args))
     check _loc (HsAppTy l r)           args = checkl l (r:args)
     check _loc (HsOpTy l (L loc tc) r) args = check loc (HsTyVar tc) (l:r:args)
     check _loc (HsParTy t)            args = checkl t args

-    check loc _                        _    = parseError loc  "malformed class assertion"
-
-checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
-checkDictTy (L spn ty) = check ty []
-  where
-  check (HsTyVar t) args | not (isRdrTyVar t) 
-       = return (L spn (HsPredTy (HsClassP t args)))
-  check (HsAppTy l r) args = check (unLoc l) (r:args)
-  check (HsParTy t)   args = check (unLoc t) args
-  check _ _ = parseError spn "Malformed context in instance header"
-
+    check loc _                        _    = parseError loc  
+                                               "malformed class assertion"

 
 ---------------------------------------------------------------------------
 -- Checking stand-alone deriving declarations
 
 ---------------------------------------------------------------------------
 -- Checking stand-alone deriving declarations

diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 53f04e2..8774b40 100644 (file)
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -87,6 +87,8 @@ extractHsCtxtTyNames (L _ ctxt)
 -- so don't mention the IP names
 extractHsPredTyNames (HsClassP cls tys)
   = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
 -- so don't mention the IP names
 extractHsPredTyNames (HsClassP cls tys)
   = unitNameSet cls `unionNameSets` extractHsTyNames_s tys

+extractHsPredTyNames (HsEqualP ty1 ty2)
+  = extractHsTyNames ty1 `unionNameSets` extractHsTyNames ty2

 extractHsPredTyNames (HsIParam n ty)
   = extractHsTyNames ty
 \end{code}
 extractHsPredTyNames (HsIParam n ty)
   = extractHsTyNames ty
 \end{code}

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index fe51c1a..8dbf887 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -505,14 +505,20 @@ rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 rnLPred doc  = wrapLocM (rnPred doc)
 
 rnPred doc (HsClassP clas tys)
 rnLPred doc  = wrapLocM (rnPred doc)
 
 rnPred doc (HsClassP clas tys)

-  = lookupOccRn clas           `thenM` \ clas_name ->
-    rnLHsTypes doc tys         `thenM` \ tys' ->
-    returnM (HsClassP clas_name tys')
-
+  = do { clas_name <- lookupOccRn clas
+       ; tys' <- rnLHsTypes doc tys
+       ; returnM (HsClassP clas_name tys')
+       }
+rnPred doc (HsEqualP ty1 ty2)
+  = do { ty1' <- rnLHsType doc ty1
+       ; ty2' <- rnLHsType doc ty2
+       ; returnM (HsEqualP ty1' ty2')
+       }

 rnPred doc (HsIParam n ty)
 rnPred doc (HsIParam n ty)

-  = newIPNameRn n              `thenM` \ name ->
-    rnLHsType doc ty           `thenM` \ ty' ->
-    returnM (HsIParam name ty')
+  = do { name <- newIPNameRn n
+       ; ty' <- rnLHsType doc ty
+       ; returnM (HsIParam name ty')
+       }

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 6f92e4b..4d3224c 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -388,13 +388,21 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind)
        -- Does *not* check for a saturated
        -- application (reason: used from TcDeriv)
 kc_pred pred@(HsIParam name ty)
        -- Does *not* check for a saturated
        -- application (reason: used from TcDeriv)
 kc_pred pred@(HsIParam name ty)

-  = kcHsType ty                `thenM` \ (ty', kind) ->
-    returnM (HsIParam name ty', kind)
-
+  = do { (ty', kind) <- kcHsType ty
+       ; returnM (HsIParam name ty', kind)
+       }

 kc_pred pred@(HsClassP cls tys)
 kc_pred pred@(HsClassP cls tys)

-  = kcClass cls                        `thenM` \ kind ->
-    kcApps kind (ppr cls) tys  `thenM` \ (tys', res_kind) ->
-    returnM (HsClassP cls tys', res_kind)
+  = do { kind <- kcClass cls
+       ; (tys', res_kind) <- kcApps kind (ppr cls) tys
+       ; returnM (HsClassP cls tys', res_kind)
+       }
+kc_pred pred@(HsEqualP ty1 ty2)
+  = do { (ty1', kind1) <- kcHsType ty1
+       ; checkExpectedKind ty1 kind1 liftedTypeKind
+       ; (ty2', kind2) <- kcHsType ty2
+       ; checkExpectedKind ty2 kind2 liftedTypeKind
+       ; returnM (HsEqualP ty1 ty2, liftedTypeKind)
+       }

 
 ---------------------------
 kcTyVar :: Name -> TcM TcKind
 
 ---------------------------
 kcTyVar :: Name -> TcM TcKind

@@ -534,13 +542,19 @@ dsHsLPred :: LHsPred Name -> TcM PredType
 dsHsLPred pred = dsHsPred (unLoc pred)
 
 dsHsPred pred@(HsClassP class_name tys)
 dsHsLPred pred = dsHsPred (unLoc pred)
 
 dsHsPred pred@(HsClassP class_name tys)

-  = dsHsTypes tys                      `thenM` \ arg_tys ->
-    tcLookupClass class_name           `thenM` \ clas ->
-    returnM (ClassP clas arg_tys)
-
+  = do { arg_tys <- dsHsTypes tys
+       ; clas <- tcLookupClass class_name
+       ; returnM (ClassP clas arg_tys)
+       }
+dsHsPred pred@(HsEqualP ty1 ty2)
+  = do { arg_ty1 <- dsHsType ty1
+       ; arg_ty2 <- dsHsType ty2
+       ; returnM (EqPred arg_ty1 arg_ty2)
+       }

 dsHsPred (HsIParam name ty)
 dsHsPred (HsIParam name ty)

-  = dsHsType ty                                        `thenM` \ arg_ty ->
-    returnM (IParam name arg_ty)
+  = do { arg_ty <- dsHsType ty
+       ; returnM (IParam name arg_ty)
+       }

 \end{code}
 
 GADT constructor signatures
 \end{code}
 
 GADT constructor signatures

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index b4e89b0..f206b5e 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -924,14 +924,14 @@ check_valid_theta ctxt theta
 
 -------------------------
 check_pred_ty dflags ctxt pred@(ClassP cls tys)
 
 -------------------------
 check_pred_ty dflags ctxt pred@(ClassP cls tys)

-  =    -- Class predicates are valid in all contexts
-    checkTc (arity == n_tys) arity_err         `thenM_`
-
-       -- Check the form of the argument types
-    mappM_ check_arg_type tys                          `thenM_`
-    checkTc (check_class_pred_tys dflags ctxt tys)
-           (predTyVarErr pred $$ how_to_allow)
-
+  = do {       -- Class predicates are valid in all contexts
+       ; checkTc (arity == n_tys) arity_err
+
+               -- Check the form of the argument types
+       ; mappM_ check_arg_type tys
+       ; checkTc (check_class_pred_tys dflags ctxt tys)
+                (predTyVarErr pred $$ how_to_allow)
+       }

   where
     class_name = className cls
     arity      = classArity cls
   where
     class_name = className cls
     arity      = classArity cls

@@ -939,10 +939,23 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity_err  = arityErr "Class" class_name arity n_tys
     how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this"))
 
     arity_err  = arityErr "Class" class_name arity n_tys
     how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this"))
 

+check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
+  = do {       -- Equational constraints are valid in all contexts if indexed
+               -- types are permitted
+       ; checkTc (dopt Opt_IndexedTypes dflags) (eqPredTyErr pred)
+
+               -- Check the form of the argument types
+       ; check_eq_arg_type ty1
+       ; check_eq_arg_type ty2
+       }
+  where 
+    check_eq_arg_type = check_poly_type (Rank 0) UT_NotOk
+

 check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty
 check_pred_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty

-       -- Implicit parameters only allows in type
+       -- Implicit parameters only allowed in type

        -- signatures; not in instance decls, superclasses etc
        -- signatures; not in instance decls, superclasses etc

-       -- The reason for not allowing implicit params in instances is a bit subtle
+       -- The reason for not allowing implicit params in instances is a bit
+       -- subtle.

        -- If we allowed        instance (?x::Int, Eq a) => Foo [a] where ...
        -- then when we saw (e :: (?x::Int) => t) it would be unclear how to 
        -- discharge all the potential usas of the ?x in e.   For example, a
        -- If we allowed        instance (?x::Int, Eq a) => Foo [a] where ...
        -- then when we saw (e :: (?x::Int) => t) it would be unclear how to 
        -- discharge all the potential usas of the ?x in e.   For example, a

@@ -1057,6 +1070,9 @@ checkThetaCtxt ctxt theta
          ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
 
 badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
          ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
 
 badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty

+eqPredTyErr  sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty
+                  $$
+                  parens (ptext SLIT("Use -findexed-types to permit this"))

 predTyVarErr pred  = sep [ptext SLIT("Non type-variable argument"),
                          nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
 predTyVarErr pred  = sep [ptext SLIT("Non type-variable argument"),
                          nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 60474b1..db151f1 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -59,7 +59,7 @@ module TcType (
 
   ---------------------------------
   -- Misc type manipulators
 
   ---------------------------------
   -- Misc type manipulators

-  deNoteType, classesOfTheta,
+  deNoteType,

   tyClsNamesOfType, tyClsNamesOfDFunHead, 
   getDFunTyKey,
 
   tyClsNamesOfType, tyClsNamesOfDFunHead, 
   getDFunTyKey,
 

@@ -540,7 +540,7 @@ mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 
 mkPhiTy :: [PredType] -> Type -> Type
 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 
 mkPhiTy :: [PredType] -> Type -> Type

-mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
+mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta

 \end{code}
 
 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
 \end{code}
 
 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.

@@ -850,7 +850,8 @@ isInheritablePred :: PredType -> Bool
 -- but it doesn't need to be quantified over the Num a dictionary
 -- which can be free in g's rhs, and shared by both calls to g
 isInheritablePred (ClassP _ _) = True
 -- but it doesn't need to be quantified over the Num a dictionary
 -- which can be free in g's rhs, and shared by both calls to g
 isInheritablePred (ClassP _ _) = True

-isInheritablePred other             = False
+isInheritablePred (EqPred _ _) = True
+isInheritablePred other               = False

 \end{code}
 
 --------------------- Equality predicates ---------------------------------
 \end{code}
 
 --------------------- Equality predicates ---------------------------------

@@ -1043,10 +1044,6 @@ tyClsNamesOfDFunHead :: Type -> NameSet
 tyClsNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
        (tvs,_,head_ty) -> tyClsNamesOfType head_ty
 tyClsNamesOfDFunHead dfun_ty 
   = case tcSplitSigmaTy dfun_ty of
        (tvs,_,head_ty) -> tyClsNamesOfType head_ty

-
-classesOfTheta :: ThetaType -> [Class]
--- Looks just for ClassP things; maybe it should check
-classesOfTheta preds = [ c | ClassP c _ <- preds ]

 \end{code}
 
 
 \end{code}