mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
- mkHsDo, mkHsSplice,
+ mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
splitCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindsAndSigs,
cvTopDecls,
findSplice, checkDecBrGroup,
+ placeHolderPunRhs,
-- Stuff to do with Foreign declarations
mkImport,
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]
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
- isRdrDataCon, isUnqual, getRdrName, isQual,
- setRdrNameSpace, showRdrName )
+ isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
InlinePragma(..), InlineSpec(..),
alwaysInlineSpec, neverInlineSpec )
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) $
= 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}
%************************************************************************
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.
"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]
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of
- EWildPat -> return (WildPat placeHolderType)
- HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
- ++ showRdrName x)
- | otherwise -> return (VarPat x)
- HsLit l -> return (LitPat l)
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar x -> return (VarPat x)
+ HsLit l -> return (LitPat l)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
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)
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
- | isQual (unLoc fun)
- = parseErrorSDoc (getLoc fun)
- (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
- | otherwise
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])