[project @ 2005-05-17 07:48:20 by simonmar]

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

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 5a258a1..1977a54 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -20,30 +20,30 @@ module RdrHsSyn (
        findSplice, mkGroup,
 
        -- Stuff to do with Foreign declarations
-       , CallConv(..)
-       , mkImport            -- CallConv -> Safety 
+       CallConv(..),
+       mkImport,            -- CallConv -> Safety 
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl
-       , mkExport            -- CallConv
+       mkExport,            -- CallConv
                              -- -> (FastString, RdrName, RdrNameHsType)
                              -- -> P RdrNameHsDecl
-       , mkExtName           -- RdrName -> CLabelString
+       mkExtName,           -- RdrName -> CLabelString
                              
        -- Bunch of functions in the parser monad for 
        -- checking and constructing values
-       , checkPrecP          -- Int -> P Int
-       , checkContext        -- HsType -> P HsContext
-       , checkPred           -- HsType -> P HsPred
-       , checkTyClHdr
-       , checkSynHdr   
-       , checkInstType       -- HsType -> P HsType
-       , checkPattern        -- HsExp -> P HsPat
-       , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
-       , checkDo             -- [Stmt] -> P [Stmt]
-       , checkMDo            -- [Stmt] -> P [Stmt]
-       , checkValDef         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-       , checkValSig         -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-       , parseError          -- String -> Pa
+       checkPrecP,           -- Int -> P Int
+       checkContext,         -- HsType -> P HsContext
+       checkPred,            -- HsType -> P HsPred
+       checkTyClHdr,
+       checkSynHdr,    
+       checkInstType,        -- HsType -> P HsType
+       checkPattern,         -- HsExp -> P HsPat
+       checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
+       checkDo,              -- [Stmt] -> P [Stmt]
+       checkMDo,             -- [Stmt] -> P [Stmt]
+       checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+       checkValSig,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+       parseError,           -- String -> Pa
     ) where
 
 #include "HsVersions.h"
@@ -172,7 +172,7 @@ mkHsNegApp (L loc e) = f e
   where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
        f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
        f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
-       f expr                     = NegApp (L loc e) placeHolderName
+       f expr                     = NegApp (L loc e) noSyntaxExpr
 \end{code}
 
 %************************************************************************
@@ -187,7 +187,7 @@ analyser.
 
 
 \begin{code}
--- | Groups together bindings for a single function
+--  | Groups together bindings for a single function
 cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
 cvTopDecls decls = go (fromOL decls)
   where
@@ -252,16 +252,13 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 \end{code}
 
 \begin{code}
-emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
-                      hs_tyclds = [], hs_instds = [],
-                      hs_fixds = [], hs_defds = [], hs_fords = [], 
-                      hs_depds = [] ,hs_ruleds = [] }
-
 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-findSplice ds = addl emptyGroup ds
+findSplice ds = addl oneEmptyBindGroup ds
 
 mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyGroup ds
+mkGroup ds = addImpDecls oneEmptyBindGroup ds
+
+oneEmptyBindGroup = emptyGroup{ hs_valds = [HsBindGroup emptyBag [] Recursive] }
 
 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 -- The decls are imported, and should not have a splice
@@ -468,23 +465,23 @@ checkDictTy (L spn ty) = check ty []
 --     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
+--        (b) returns it separately
 -- same comments apply for mdo as well
 
 checkDo         = checkDoMDo "a " "'do'"
 checkMDo = checkDoMDo "an " "'mdo'"
 
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
+checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
 checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
 checkDoMDo pre nm loc ss   = do 
   check ss
   where 
-       check  [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
+       check  [L l (ExprStmt e _ _)] = return ([], e)
        check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
                                         " construct must be an expression")
        check (s:ss) = do
-         ss' <-  check ss
-         return (s:ss')
+         (ss',e') <-  check ss
+         return ((s:ss'),e')
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
@@ -524,9 +521,9 @@ checkAPat loc e = case e of
    -- Negation is recorded separately, so that the literal is zero or +ve
    -- NB. Negative *primitive* literals are already handled by
    --     RdrHsSyn.mkHsNegApp
-   HsOverLit pos_lit            -> return (NPatIn pos_lit Nothing)
+   HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
    NegApp (L _ (HsOverLit pos_lit)) _ 
-                       -> return (NPatIn pos_lit (Just placeHolderName))
+                       -> return (mkNPat pos_lit (Just noSyntaxExpr))
    
    ELazyPat e     -> checkLPat e >>= (return . LazyPat)
    EAsPat n e     -> checkLPat e >>= (return . AsPat n)
@@ -564,7 +561,7 @@ checkAPat loc e = case e of
    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
                         return (TuplePat ps b)
    
-   RecordCon c fs     -> mapM checkPatField fs >>= \fs ->
+   RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
                         return (ConPatIn c (RecCon fs))
 -- Generics 
    HsType ty          -> return (TypePat ty) 
@@ -644,9 +641,9 @@ mkRecConstrOrUpdate
        -> P (HsExpr RdrName)
 
 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
-  = return (RecordCon (L l c) fs)
+  = return (RecordCon (L l c) noPostTcExpr fs)
 mkRecConstrOrUpdate exp loc fs@(_:_)
-  = return (RecordUpd exp fs)
+  = return (RecordUpd exp fs placeHolderType placeHolderType)
 mkRecConstrOrUpdate _ loc []
   = parseError loc "Empty record update"