[project @ 2001-05-18 09:18:05 by simonmar]

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

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 9610106..47b0d16 100644 (file)
--- 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
@@ -37,12 +37,12 @@ import RdrHsSyn             ( RdrBinding(..),
                          RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
                        )
 import RdrName
-import PrelNames       ( unitTyCon_RDR, minus_RDR )
+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,9 @@ 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 (NPlusKPatIn n lit minus_RDR)
+                          -> returnP (NPlusKPatIn n lit)
                           where
                              plus_RDR = mkUnqual varName SLIT("+")     -- Hack
 
@@ -249,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
@@ -271,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)