Fix bogus check for strictness in newtypes

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

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index c29f23a..9cc6c65 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -9,7 +9,7 @@ module RdrHsSyn (
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl,
-       mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
+       mkHsIntegral, mkHsFractional, mkHsIsString,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -17,7 +17,7 @@ module RdrHsSyn (
        cvBindGroup,
         cvBindsAndSigs,
        cvTopDecls,
-       findSplice, mkGroup,
+       findSplice, checkDecBrGroup,
 
        -- Stuff to do with Foreign declarations
        CallConv(..),
@@ -69,7 +69,6 @@ import OrdList                ( OrdList, fromOL )
 import Bag             ( Bag, emptyBag, snocBag, consBag, foldrBag )
 import Outputable
 import FastString
-import Panic
 
 import List            ( isSuffixOf, nubBy )
 import Monad           ( unless )
@@ -173,18 +172,6 @@ mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
             tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 
-\begin{code}
-mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
--- RdrName If the type checker sees (negate 3#) it will barf, because negate
--- can't take an unboxed arg.  But that is exactly what it will see when
--- we write "-3#".  So we have to do the negation right now!
-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) noSyntaxExpr
-\end{code}
-
 %************************************************************************
 %*                                                                     *
 \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
@@ -281,14 +268,15 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
 findSplice ds = addl emptyRdrGroup ds
 
-mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyRdrGroup ds
-
-addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
--- The decls are imported, and should not have a splice
-addImpDecls group decls = case addl group decls of
-                               (group', Nothing) -> group'
-                               other             -> panic "addImpDecls"
+checkDecBrGroup :: [LHsDecl a] -> P (HsGroup a)
+-- Turn the body of a [d| ... |] into a HsGroup
+-- There should be no splices in the "..."
+checkDecBrGroup decls 
+  = case addl emptyRdrGroup decls of
+       (group, Nothing) -> return group
+       (_, Just (SpliceDecl (L loc _), _)) -> 
+               parseError loc "Declaration splices are not permitted inside declaration brackets"
+               -- Why not?  See Section 7.3 of the TH paper.  
 
 addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
        -- This stuff reverses the declarations (again) but it doesn't matter
@@ -309,8 +297,6 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
        | isClassDecl d =       
                let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
                addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
-       | isFamInstDecl d = 
-               addl (gp { hs_tyclds = L l d : ts }) ds
        | otherwise =
                addl (gp { hs_tyclds = L l d : ts }) ds
 
@@ -658,8 +644,7 @@ checkAPat loc e = case e of
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
-   -- NB. Negative *primitive* literals are already handled by
-   --     RdrHsSyn.mkHsNegApp
+   -- NB. Negative *primitive* literals are already handled by the lexer
    HsOverLit pos_lit            -> return (mkNPat pos_lit Nothing)
    NegApp (L _ (HsOverLit pos_lit)) _ 
                        -> return (mkNPat pos_lit (Just noSyntaxExpr))
@@ -873,7 +858,7 @@ mkRecConstrOrUpdate
 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
   = return (RecordCon (L l c) noPostTcExpr fs)
 mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
-  = return (RecordUpd exp fs placeHolderType placeHolderType)
+  = return (RecordUpd exp fs [] [] [])
 mkRecConstrOrUpdate _ loc (HsRecordBinds [])
   = parseError loc "Empty record update"