X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=47b0d16e19b299a9c2e6951e7a4ec8218a23044b;hb=9213df4a0c5a8f121832d36d6d3afbf1c80f1a0a;hp=5f929c6d5363f94d5d4b0b1f8e2b0742566ffd5d;hpb=54c848ff4e46056908c53c2bc7db1d806551ba39;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 5f929c6..47b0d16 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -20,8 +20,8 @@ module ParseUtil (
 	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
 	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
 	, checkPattern		-- HsExp -> P HsPat
-	, checkPatterns		-- [HsExp] -> P [HsPat]
-	-- , checkExpr		-- HsExp -> P HsExp
+	, checkPatterns		-- SrcLoc -> [HsExp] -> P [HsPat]
+	, checkDo		-- [HsStmt] -> P [HsStmt]
 	, checkValDef		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	, checkValSig		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  ) where
@@ -31,18 +31,18 @@ module ParseUtil (
 import Lex
 import HsSyn		-- Lots of it
 import SrcLoc
-import RdrHsSyn		( mkNPlusKPatIn, unitTyCon_RDR,
-			  RdrBinding(..),
+import RdrHsSyn		( RdrBinding(..),
 			  RdrNameHsType, RdrNameBangType, RdrNameContext,
 			  RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
 			  RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
 			)
 import RdrName
+import PrelNames	( unitTyCon_RDR )
 import CallConv
 import OccName  	( dataName, varName, tcClsName,
 			  occNameSpace, setOccNameSpace, occNameUserString )
 import FastString	( unpackFS )
-import UniqFM		( UniqFM, listToUFM, lookupUFM )
+import UniqFM		( UniqFM, listToUFM )
 import Outputable
 
 -----------------------------------------------------------------------------
@@ -68,7 +68,7 @@ mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDeta
 mkVanillaCon ty tys
  = split ty tys
  where
-   split (HsAppTy t u)  ts = split t (Unbanged u : ts)
+   split (HsAppTy t u)  ts = split t (unbangedType u : ts)
    split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
 			     returnP (data_con, VanillaCon ts)
    split _		 _ = parseError "Illegal data/newtype declaration"
@@ -100,13 +100,6 @@ callConvFM = listToUFM $
 --	("fastcall", fastCallConv)
      ]
 
-checkCallConv :: FAST_STRING -> P CallConv
-checkCallConv s = 
-  case lookupUFM callConvFM s of
-	Nothing -> parseError ("unknown calling convention: `"
-				 ++ unpackFS s ++ "'")
-	Just conv -> returnP conv
-
 checkInstType :: RdrNameHsType -> P RdrNameHsType
 checkInstType t 
   = case t of
@@ -130,16 +123,16 @@ checkContext t
 checkPred :: RdrNameHsType -> [RdrNameHsType] 
 	-> P (HsPred RdrName)
 checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
-  	= returnP (HsPClass t args)
+  	= returnP (HsClassP t args)
 checkPred (HsAppTy l r) args = checkPred l (r:args)
-checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
+checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
 checkPred _ _ = parseError "Illegal class assertion"
 
 checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
 checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
   	= returnP (mkHsDictTy t args)
 checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
-checkDictTy _ _ = parseError "Illegal class assertion"
+checkDictTy _ _ = parseError "Malformed context in instance header"
 
 -- Put more comments!
 -- Checks that the lhs of a datatype declaration
@@ -167,16 +160,29 @@ checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
 
 ---------------------------------------------------------------------------
+-- Checking statements in a do-expression
+-- 	We parse   do { e1 ; e2 ; }
+-- 	as [ExprStmt e1, ExprStmt e2]
+-- checkDo (a) checks that the last thing is an ExprStmt
+--	   (b) transforms it to a ResultStmt
+
+checkDo []	       = parseError "Empty 'do' construct"
+checkDo [ExprStmt e l] = returnP [ResultStmt e l]
+checkDo [s] 	       = parseError "The last statment in a 'do' construct must be an expression"
+checkDo (s:ss)	       = checkDo ss	`thenP` \ ss' ->
+			 returnP (s:ss')
+
+---------------------------------------------------------------------------
 -- Checking Patterns.
 
 -- We parse patterns as expressions and check for valid patterns below,
 -- converting the expression into a pattern at the same time.
 
-checkPattern :: RdrNameHsExpr -> P RdrNamePat
-checkPattern e = checkPat e []
+checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
+checkPattern loc e = setSrcLocP loc (checkPat e [])
 
-checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
-checkPatterns es = mapP checkPattern es
+checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns loc es = mapP (checkPattern loc) es
 
 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
@@ -200,9 +206,11 @@ checkPat e [] = case e of
 			      in
 			      returnP (SigPatIn e t')
 
-	OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) 
+	OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k)) 
 		  	   | plus == plus_RDR
-			   -> returnP (mkNPlusKPatIn n lit)
+			   -> returnP (NPlusKPatIn n lit)
+			   where
+			      plus_RDR = mkUnqual varName SLIT("+")	-- Hack
 
 	OpApp l op fix r   -> checkPat l [] `thenP` \l ->
 			      checkPat r [] `thenP` \r ->
@@ -247,11 +255,11 @@ checkValDef
 checkValDef lhs opt_sig grhss loc
  = case isFunLhs lhs [] of
 	   Just (f,inf,es) -> 
-		checkPatterns es `thenP` \ps ->
+		checkPatterns loc es `thenP` \ps ->
 		returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
 
            Nothing ->
-		checkPattern lhs `thenP` \lhs ->
+		checkPattern loc lhs `thenP` \lhs ->
 		returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 
 checkValSig
@@ -269,6 +277,11 @@ checkValSig other     ty loc = parseError "Type signature given for an expressio
 isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
 isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 			  	= Just (op, True, (l:r:es))
+					| otherwise
+				= case isFunLhs l es of
+				    Just (op', True, j : k : es') ->
+				      Just (op', True, j : OpApp k (HsVar op) fix r : es')
+				    _ -> Nothing
 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 			 	= Just (f,False,es)
 isFunLhs (HsApp f e) es 	= isFunLhs f (e:es)
@@ -334,6 +347,4 @@ groupBindings binds = group Nothing binds
 	    = case bind of
 		RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
 		other -> bind `RdrAndBindings` group Nothing binds
-
-plus_RDR = mkSrcUnqual varName SLIT("+")
 \end{code}