X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FRdrHsSyn.lhs;h=03ca542149c8b7e5fb245203662ea146b94d291e;hb=1e436f2bb208a6c990743afaf17b7c2a93c31742;hp=5d54c2f02cbc95726004808b5d0d82af1e1b477b;hpb=1fede4bc9501744bf2269ce2a4cb9fb735969caa;p=ghc-hetmet.git diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 5d54c2f..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] @@ -53,8 +53,7 @@ import HsSyn -- Lots of it 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 ) @@ -129,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) $ @@ -224,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} %************************************************************************ @@ -256,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. @@ -659,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] @@ -728,11 +733,9 @@ checkPat loc _ _ 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 @@ -792,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) @@ -831,10 +840,6 @@ checkFunBind :: SrcSpan -> 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)])