extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
cvBindsAndSigs,
cvTopDecls,
- findSplice, mkGroup,
+ findSplice, checkDecBrGroup,
-- Stuff to do with Foreign declarations
CallConv(..),
#include "HsVersions.h"
import HsSyn -- Lots of it
-import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
import Outputable
import FastString
-import Panic
import List ( isSuffixOf, nubBy )
import Monad ( unless )
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.}
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
| 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
where
gol (L l ty) acc = go l ty acc
- go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = do
- tvs <- extractTyVars acc
- return (L l tc, tvs, acc)
- go l (HsOpTy t1 tc t2) acc = do
- tvs <- extractTyVars (t1:t2:acc)
- return (tc, tvs, acc)
+ go l (HsTyVar tc) acc
+ | isRdrTc tc = do tvs <- extractTyVars acc
+ return (L l tc, tvs, acc)
+ go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+ | isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
+ return (ltc, tvs, acc)
go l (HsParTy ty) acc = gol ty acc
go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
go l other acc =
-- 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))
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b placeHolderType)
- RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
+ RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc []
+mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
+ = return (RecordUpd exp fs [] [] [])
+mkRecConstrOrUpdate _ loc (HsRecordBinds [])
= parseError loc "Empty record update"
mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec