[project @ 2001-07-12 16:21:22 by simonpj]

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

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index e444450..1f8a1f1 100644 (file)
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -6,13 +6,12 @@
 \begin{code}
 module ParseUtil (
          parseError            -- String -> Pa
-       , cbot                  -- a
        , mkVanillaCon, mkRecCon,
 
        , mkRecConstrOrUpdate   -- HsExp -> [HsFieldUpdate] -> P HsExp
        , groupBindings
        
-       , mkExtName             -- Maybe ExtName -> RdrName -> ExtName
+       , mkExtName             -- RdrName -> ExtName
 
        , checkPrec             -- String -> P String
        , checkContext          -- HsType -> P HsContext
@@ -20,8 +19,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
@@ -38,11 +37,10 @@ import RdrHsSyn             ( RdrBinding(..),
                        )
 import RdrName
 import PrelNames       ( unitTyCon_RDR )
-import CallConv
 import OccName         ( dataName, varName, tcClsName,
                          occNameSpace, setOccNameSpace, occNameUserString )
+import CStrings                ( CLabelString )
 import FastString      ( unpackFS )
-import UniqFM          ( UniqFM, listToUFM, lookupUFM )
 import Outputable
 
 -----------------------------------------------------------------------------
@@ -53,7 +51,6 @@ parseError s =
   getSrcLocP `thenP` \ loc ->
   failMsgP (hcat [ppr loc, text ": ", text s])
 
-cbot = panic "CCall:result_ty"
 
 -----------------------------------------------------------------------------
 -- mkVanillaCon
@@ -68,7 +65,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"
@@ -91,22 +88,6 @@ tyConToDataCon tc
 ----------------------------------------------------------------------------
 -- Various Syntactic Checks
 
-callConvFM :: UniqFM CallConv
-callConvFM = listToUFM $
-      map (\ (x,y) -> (_PK_ x,y))
-     [  ("stdcall",  stdCallConv),
-       ("ccall",    cCallConv)
---     ("pascal",   pascalCallConv),
---     ("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
@@ -167,16 +148,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 statement 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)
@@ -213,7 +207,7 @@ checkPat e [] = case e of
                                 _ -> patFail
 
        HsPar e            -> checkPat e [] `thenP` (returnP . ParPatIn)
-       ExplicitList es    -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+       ExplicitList _ es  -> mapP (\e -> checkPat e []) es `thenP` \ps ->
                              returnP (ListPatIn ps)
 
        ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
@@ -249,11 +243,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
@@ -275,7 +269,7 @@ isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
                                = case isFunLhs l es of
                                    Just (op', True, j : k : es') ->
                                      Just (op', True, j : OpApp k (HsVar op) fix r : es')
-                                   Nothing -> Nothing
+                                   _ -> Nothing
 isFunLhs (HsVar f) es | not (isRdrDataCon f)
                                = Just (f,False,es)
 isFunLhs (HsApp f e) es        = isFunLhs f (e:es)
@@ -308,10 +302,8 @@ mkRecConstrOrUpdate _ _
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 -- (This is why we use occNameUserString.)
 
-mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
-                                 Nothing
-mkExtName (Just x) _    = x
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 
 -----------------------------------------------------------------------------
 -- group function bindings into equation groups