[project @ 2000-02-09 18:32:09 by lewie]

[ghc-hetmet.git] / ghc / compiler / parser / ParseUtil.lhs

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 5f63937..c396e3f 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -136,16 +136,24 @@ checkInstType t
 
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (MonoTupleTy ts True) 
-  = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
-    returnP cs
+  = mapP (\t -> checkPred t []) ts `thenP` \ps ->
+    returnP ps
 checkContext (MonoTyVar t) -- empty contexts are allowed
   | t == unitTyCon_RDR = returnP []
 checkContext t 
-  = checkAssertion t [] `thenP` \c ->
-    returnP [c]
+  = checkPred t [] `thenP` \p ->
+    returnP [p]
+
+checkPred :: RdrNameHsType -> [RdrNameHsType] 
+       -> P (HsPred RdrName)
+checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
+       = returnP (HsPClass t args)
+checkPred (MonoTyApp l r) args = checkPred l (r:args)
+checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
+checkPred _ _ = parseError "Illegal class assertion"
 
 checkAssertion :: RdrNameHsType -> [RdrNameHsType] 
-       -> P (ClassAssertion RdrName)
+       -> P (HsClassAssertion RdrName)
 checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) 
        = returnP (t,args)
 checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
@@ -186,7 +194,7 @@ checkPat (HsApp f x) args =
 checkPat e [] = case e of
        EWildPat           -> returnP WildPatIn
        HsVar x            -> returnP (VarPatIn x)
-       HsLit l            -> returnP (LitPatIn l)
+       HsLit l            -> returnP (LitPatIn l)
        ELazyPat e         -> checkPat e [] `thenP` (returnP . LazyPatIn)
        EAsPat n e         -> checkPat e [] `thenP` (returnP . AsPatIn n)
         ExprWithTySig e t  -> checkPat e [] `thenP` \e ->
@@ -239,6 +247,7 @@ patterns).
 checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
 checkExpr e = case e of
        HsVar _                   -> returnP e
+       HsIPVar _                 -> returnP e
        HsLit _                   -> returnP e
        HsLam match               -> checkMatch match `thenP` (returnP.HsLam)
        HsApp e1 e2               -> check2Exprs e1 e2 HsApp
@@ -335,8 +344,8 @@ checkValDef lhs opt_sig grhss loc
 
 -- A variable binding is parsed as an RdrNamePatBind.
 
-isFunLhs (OpApp l (HsVar op) fix r) []  | not (isRdrDataCon op)
-                               = Just (op, True, [l,r])
+isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
+                               = Just (op, True, (l:r:es))
 isFunLhs (HsVar f) es@(_:_)  | not (isRdrDataCon f)
                                = Just (f,False,es)
 isFunLhs (HsApp f e) es        = isFunLhs f (e:es)