X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=2edb72dadaa382d6cce49cdebaf3cfc0a4e2ff11;hb=403ab78dfec15dd131ee48417e096ea28ef53fd9;hp=3ab1c421a7103f27ee4b4d15117633013fac5f31;hpb=942fd04666dfbcb6bf3088ab0ef55e60d18ae67a;p=ghc-hetmet.git diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 3ab1c42..2edb72d 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -30,6 +30,9 @@ module RnPat (-- main entry points -- Literals rnLit, rnOverLit, + -- Quasiquotation + rnQuasiQuote, + -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr ) where @@ -37,6 +40,9 @@ module RnPat (-- main entry points -- ENH: thin imports to only what is necessary for patterns import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuotePat ) +#endif /* GHCI */ #include "HsVersions.h" @@ -57,14 +63,16 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, eqClassName, integralClassName, geName, eqName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName, fromStringName ) + ratioDataConName, fromRationalName, fromStringName, mkUnboundName ) import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan ) +import Name ( Name, nameOccName, nameModule_maybe, getOccName, nameSrcSpan ) +import OccName ( occEnvElts ) import NameSet -import UniqFM -import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName ) +import LazyUniqFM +import RdrName ( RdrName, GlobalRdrElt(..), Provenance(..), + extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, + mkRdrUnqual, nameRdrName, gre_name, globalRdrEnvElts, isLocalGRE ) import LoadIface ( loadInterfaceForName ) -import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import List ( nub ) import Util ( isSingleton ) @@ -161,21 +169,23 @@ rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages -> RnM (a, FreeVars) rnPatsAndThen_LocalRightwards ctxt pats thing_inside - = do { -- Check for duplicated and shadowed names - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - let rdr_names_w_loc = collectLocatedPatsBinders pats - ; checkDupNames doc_pat rdr_names_w_loc - ; checkShadowing doc_pat rdr_names_w_loc + = do { envs_before <- getRdrEnvs -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - rnLPatsAndThen matchNameMaker pats $ - thing_inside } + rnLPatsAndThen matchNameMaker pats $ \ pats' -> + do { -- Check for duplicated and shadowed names + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + ; let names = collectPatsBinders pats' + ; checkDupNames doc_pat names + ; checkShadowedNames doc_pat envs_before + [(nameSrcSpan name, nameOccName name) | name <- names] + ; thing_inside pats' } } where doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt @@ -233,15 +243,15 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) - SigPatIn pat ty -> - doptM Opt_PatternSignatures `thenM` \ patsigs -> + SigPatIn pat ty -> do + patsigs <- doptM Opt_PatternSignatures if patsigs - then rnLPatAndThen var pat + then rnLPatAndThen var pat (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty ; (res, fvs2) <- lcont (SigPatIn pat' ty') ; return (res, fvs1 `plusFV` fvs2) }) - else addErr (patSigErr ty) `thenM_` - rnLPatAndThen var pat cont + else do addErr (patSigErr ty) + rnLPatAndThen var pat cont where tvdoc = text "In a pattern type-signature" @@ -288,6 +298,16 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = lcont (ViewPat expr' pat' ty) ; return (res, fvs_res `plusFV` fv_expr) } +#ifndef GHCI + pat@(QuasiQuotePat _) -> pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) +#else + QuasiQuotePat qq -> do + (qq', _) <- rnQuasiQuote qq + pat' <- runQuasiQuotePat qq' + rnLPatAndThen var pat' $ \ (L _ pat'') -> + lcont pat'' +#endif /* GHCI */ + ConPatIn con stuff -> -- rnConPatAndThen takes care of reconstructing the pattern rnConPatAndThen var con stuff cont @@ -384,13 +404,14 @@ rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = -- each list represents a RdrName that occurred more than once -- (the list contains all occurrences) -- invariant: each list in dup_fields is non-empty - (_, dup_fields :: [[RdrName]]) = removeDups compare + dup_fields :: [[RdrName]] + (_, dup_fields) = removeDups compare (map (unLoc . hsRecFieldId) fields) -- duplicate field reporting function field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group)) in - mappM_ field_dup_err dup_fields + mapM_ field_dup_err dup_fields -- helper to rename each field rn_field pun_ok (HsRecField field inside pun) cont = do @@ -436,9 +457,9 @@ rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = checkErr dd_flag (needFlagDotDot doingstr) let fld_names1 = map (unLoc . hsRecFieldId) fields1 case doDotDot choice of - Nothing -> addErr (badDotDot doingstr) `thenM_` - -- we return a junk value here so that error reporting goes on - cont (HsRecFields fields1 dd) + Nothing -> do addErr (badDotDot doingstr) + -- we return a junk value here so that error reporting goes on + cont (HsRecFields fields1 dd) Just (con, mk_field) -> dot_dot_fields fld_names1 con mk_field $ \ fields2 -> @@ -507,24 +528,24 @@ are made available. \begin{code} rnLit :: HsLit -> RnM () rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = returnM () +rnLit other = return () -rnOverLit (HsIntegral i _ _) - = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> +rnOverLit (HsIntegral i _ _) = do + (from_integer_name, fvs) <- lookupSyntaxName fromIntegerName if inIntRange i then - returnM (HsIntegral i from_integer_name placeHolderType, fvs) - else let + return (HsIntegral i from_integer_name placeHolderType, fvs) + else let extra_fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, -- out of small integers (DsUtils.mkIntegerLit) -- [NB: plusInteger, timesInteger aren't rebindable... -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] - in - returnM (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs) + in + return (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs) -rnOverLit (HsFractional i _ _) - = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> +rnOverLit (HsFractional i _ _) = do + (from_rat_name, fvs) <- lookupSyntaxName fromRationalName let extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- We have to make sure that the Ratio type is imported with @@ -534,14 +555,33 @@ rnOverLit (HsFractional i _ _) -- as part of the type for fromRational. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - in - returnM (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs) + return (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs) -rnOverLit (HsIsString s _ _) - = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) -> - returnM (HsIsString s from_string_name placeHolderType, fvs) +rnOverLit (HsIsString s _ _) = do + (from_string_name, fvs) <- lookupSyntaxName fromStringName + return (HsIsString s from_string_name placeHolderType, fvs) \end{code} +%************************************************************************ +%* * +\subsubsection{Quasiquotation} +%* * +%************************************************************************ + +See Note [Quasi-quote overview] in TcSplice. + +\begin{code} +rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars) +rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote) + = do { loc <- getSrcSpanM + ; [n'] <- newLocalsRn [L loc n] + ; quoter' <- (lookupOccRn quoter) + -- If 'quoter' is not in scope, proceed no further + -- Otherwise lookupOcc adds an error messsage and returns + -- an "unubound name", which makes the subsequent attempt to + -- run the quote fail + ; return (HsQuasiQuote n' quoter' quoteSpan quote, unitFV quoter') } +\end{code} %************************************************************************ %* * @@ -553,7 +593,7 @@ rnOverLit (HsIsString s _ _) checkTupSize :: Int -> RnM () checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE - = returnM () + = return () | otherwise = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"), nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)), @@ -572,6 +612,6 @@ bogusCharError c = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat, - ptext SLIT("Use -XViewPatterns to enalbe view patterns")] + ptext SLIT("Use -XViewPatterns to enable view patterns")] \end{code}