X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=03ca542149c8b7e5fb245203662ea146b94d291e;hb=1e436f2bb208a6c990743afaf17b7c2a93c31742;hp=59dfe02d3ee8356f96f63dead84fba09f7dd6c66;hpb=d64022dc071b587c20a693b7f355f69dc110b707;p=ghc-hetmet.git

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 59dfe02..03ca542 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -10,7 +10,7 @@ module RdrHsSyn (
  
 	mkHsOpApp, 
 	mkHsIntegral, mkHsFractional, mkHsIsString,
-	mkHsDo, mkHsSplice,
+	mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
         splitCon, mkInlineSpec,	
 	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -19,6 +19,7 @@ module RdrHsSyn (
         cvBindsAndSigs,
 	cvTopDecls,
 	findSplice, checkDecBrGroup,
+        placeHolderPunRhs,
 
 	-- Stuff to do with Foreign declarations
 	mkImport,
@@ -37,7 +38,6 @@ module RdrHsSyn (
 	checkTyVars,          -- [LHsType RdrName] -> P ()
 	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
 	checkInstType,	      -- HsType -> P HsType
-        checkDerivDecl,       -- LDerivDecl RdrName -> P (LDerivDecl RdrName)
 	checkPattern,	      -- HsExp -> P HsPat
 	bang_RDR,
 	checkPatterns,	      -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -128,7 +128,8 @@ extract_lty (L loc ty) acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty               	-> extract_lty ty acc
       HsNumTy _                 -> acc
-      HsSpliceTy _             	-> acc	-- Type splices mention no type variables
+      HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
+      HsSpliceTyOut {}         	-> acc	-- Type splices mention no type variables
       HsKindSig ty _            -> extract_lty ty acc
       HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
       HsForAllTy _ tvs cx ty    -> acc ++ (filter ((`notElem` locals) . unLoc) $
@@ -223,6 +224,20 @@ mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars tparams
        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
+
+mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
+-- If the user wrote
+--	$(e)
+-- then that's the splice, but if she wrote, say,
+--      f x
+-- then behave as if she'd written
+--      $(f x)
+mkTopSpliceDecl expr
+  = SpliceD (SpliceDecl expr')
+  where
+    expr' = case expr of
+              (L _ (HsSpliceE (HsSplice _ expr))) -> expr
+              _other                              -> expr
 \end{code}
 
 %************************************************************************
@@ -255,7 +270,7 @@ cvBindGroup binding
       	    	  	         ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
 -- associated type declarations. They might also contain Haddock comments.
@@ -658,15 +673,6 @@ checkPred (L spn ty)
 					        "malformed class assertion"
 
 ---------------------------------------------------------------------------
--- Checking stand-alone deriving declarations
-
-checkDerivDecl :: LDerivDecl RdrName -> P (LDerivDecl RdrName)
-checkDerivDecl d@(L loc _) = 
-    do stDerivOn <- extension standaloneDerivingEnabled
-       if stDerivOn then return d
-	 else parseError loc "Illegal stand-alone deriving declaration (use -XStandaloneDeriving)"
-
----------------------------------------------------------------------------
 -- Checking statements in a do-expression
 -- 	We parse   do { e1 ; e2 ; }
 -- 	as [ExprStmt e1, ExprStmt e2]
@@ -789,9 +795,15 @@ checkAPat dynflags loc e = case e of
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
 
-plus_RDR, bang_RDR :: RdrName
+placeHolderPunRhs :: HsExpr RdrName
+-- The RHS of a punned record field will be filled in by the renamer
+-- It's better not to make it an error, in case we want to print it when debugging
+placeHolderPunRhs = HsVar pun_RDR
+
+plus_RDR, bang_RDR, pun_RDR :: RdrName
 plus_RDR = mkUnqual varName (fsLit "+")	-- Hack
 bang_RDR = mkUnqual varName (fsLit "!")	-- Hack
+pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
 checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
 checkPatField fld = do	{ p <- checkLPat (hsRecFieldArg fld)