[project @ 2000-01-28 20:52:37 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 395d06c..b410fee 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -73,8 +73,14 @@ parseError s =
 
 srcParseErr :: StringBuffer -> SrcLoc -> Message
 srcParseErr s l
-  = hcat [ppr l, ptext SLIT(": parse error on input "),
-          char '`', text (lexemeToString s), char '\'']
+  = hcat [ppr l, 
+         if null token 
+            then ptext SLIT(": parse error (possibly incorrect indentation)")
+            else hcat [ptext SLIT(": parse error on input "),
+                       char '`', text token, char '\'']
+    ]
+  where 
+       token = lexemeToString s
 
 cbot = panic "CCall:result_ty"
 
@@ -131,15 +137,15 @@ checkInstType t
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (MonoTupleTy ts True) 
   = mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
-    returnP cs
+    returnP (map (uncurry HsPClass) cs)
 checkContext (MonoTyVar t) -- empty contexts are allowed
   | t == unitTyCon_RDR = returnP []
 checkContext t 
-  = checkAssertion t [] `thenP` \c ->
-    returnP [c]
+  = checkAssertion t [] `thenP` \(c,ts) ->
+    returnP [HsPClass c ts]
 
 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)
@@ -180,7 +186,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 ->
@@ -233,6 +239,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
@@ -329,8 +336,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)