X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=061df0a706f1cdbb76985261823afacaa445f3aa;hp=8c75caa99365516618e7e772ed1d2ef672080296;hb=c24a860db326c7c1c7bab837b62147a984d5aecd;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 8c75caa..061df0a 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -10,13 +10,6 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module RnPat (-- main entry points rnPatsAndThen_LocalRightwards, rnBindPat, @@ -30,54 +23,37 @@ module RnPat (-- main entry points -- Literals rnLit, rnOverLit, + -- Quasiquotation + rnQuasiQuote, + -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr ) where -- ENH: thin imports to only what is necessary for patterns -import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts) +import {-# SOURCE #-} RnExpr ( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) +#endif /* GHCI */ #include "HsVersions.h" import HsSyn import TcRnMonad import RnEnv -import HscTypes ( availNames ) -import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) -import RnTypes ( rnHsTypeFVs, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn - ) +import RnTypes import DynFlags ( DynFlag(..) ) -import BasicTypes ( FixityDirection(..) ) -import SrcLoc ( SrcSpan ) -import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, - loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - negateName, thenMName, bindMName, failMName, - eqClassName, integralClassName, geName, eqName, - negateName, minusName, lengthPName, indexPName, - plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName, fromStringName ) +import PrelNames import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan ) +import Name import NameSet -import UniqFM -import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName ) -import LoadIface ( loadInterfaceForName ) -import UniqFM ( isNullUFM ) -import UniqSet ( emptyUniqSet ) -import List ( nub ) -import Util ( isSingleton ) +import RdrName import ListSetOps ( removeDups, minusList ) -import Maybes ( expectJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc ) +import SrcLoc import FastString import Literal ( inIntRange, inCharRange ) -import List ( unzip4 ) -import Bag (foldrBag) - -import ErrUtils (Message) \end{code} @@ -97,14 +73,13 @@ matchNameMaker :: NameMaker matchNameMaker = NM (\ rdr_name thing_inside -> do { names@[name] <- newLocalsRn [rdr_name] - ; bindLocalNamesFV names $ - warnUnusedMatches names $ - thing_inside name }) + ; bindLocalNamesFV names $ do + { (res, fvs) <- thing_inside name + ; warnUnusedMatches names fvs + ; return (res, fvs) }}) topRecNameMaker, localRecNameMaker - :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names - -> NameMaker + :: MiniFixityEnv -> NameMaker -- topNameMaker and localBindMaker do not check for unused binding localRecNameMaker fix_env @@ -161,23 +136,25 @@ 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 + doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt -- entry point 2: @@ -233,15 +210,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" @@ -253,7 +230,7 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = LitPat lit -> do { rnLit lit; lcont (LitPat lit) } - NPat lit mb_neg eq -> + NPat lit mb_neg _eq -> do { (lit', fvs1) <- rnOverLit lit ; (mb_neg', fvs2) <- case mb_neg of Nothing -> return (Nothing, emptyFVs) @@ -288,6 +265,16 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = lcont (ViewPat expr' pat' ty) ; return (res, fvs_res `plusFV` fv_expr) } +#ifndef GHCI + (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 @@ -313,6 +300,8 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = ; (res, fvs2) <- lcont (TypePat name') ; return (res, fvs1 `plusFV` fvs2) } + p -> pprPanic "rnLPatAndThen" (ppr p) + -- helper for renaming constructor patterns rnConPatAndThen :: NameMaker @@ -349,14 +338,17 @@ data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a) | Pattern (Located Name) (RdrName -> a) | Update +choiceToMessage :: RnHsRecFieldsChoice t -> String choiceToMessage (Constructor _ _) = "construction" choiceToMessage (Pattern _ _) = "pattern" choiceToMessage Update = "update" +doDotDot :: RnHsRecFieldsChoice t -> Maybe (Located Name, RdrName -> t) doDotDot (Constructor a b) = Just (a,b) doDotDot (Pattern a b) = Just (a,b) doDotDot Update = Nothing +getChoiceName :: RnHsRecFieldsChoice field -> Maybe (Located Name) getChoiceName (Constructor n _) = Just n getChoiceName (Pattern n _) = Just n getChoiceName (Update) = Nothing @@ -391,7 +383,7 @@ rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = -- 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 @@ -437,21 +429,24 @@ 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 -> cont (HsRecFields (fields1 ++ fields2) dd) -needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str, - ptext SLIT("Use -XRecordWildCards to permit this")] +needFlagDotDot :: String -> SDoc +needFlagDotDot str = vcat [ptext (sLit "Illegal `..' in record") <+> text str, + ptext (sLit "Use -XRecordWildCards to permit this")] -badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str +badDotDot :: String -> SDoc +badDotDot str = ptext (sLit "You cannot use `..' in record") <+> text str -badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld), - ptext SLIT("Use -XRecordPuns to permit this")] +badPun :: Located RdrName -> SDoc +badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), + ptext (sLit "Use -XRecordPuns to permit this")] -- wrappers @@ -508,24 +503,25 @@ are made available. \begin{code} rnLit :: HsLit -> RnM () rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = returnM () +rnLit _ = return () -rnOverLit (HsIntegral i _ _) - = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> +rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) +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 @@ -535,14 +531,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} %************************************************************************ %* * @@ -554,25 +569,29 @@ 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)), - nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))]) + = 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)), + nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))]) +patSigErr :: Outputable a => a -> SDoc patSigErr ty - = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it")) + = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) + $$ nest 4 (ptext (sLit "Use -XPatternSignatures to permit it")) +dupFieldErr :: String -> RdrName -> SDoc dupFieldErr str dup - = hsep [ptext SLIT("duplicate field name"), + = hsep [ptext (sLit "duplicate field name"), quotes (ppr dup), - ptext SLIT("in record"), text str] + ptext (sLit "in record"), text str] +bogusCharError :: Char -> SDoc bogusCharError c - = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' + = 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")] +badViewPat :: Pat RdrName -> SDoc +badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat, + ptext (sLit "Use -XViewPatterns to enable view patterns")] \end{code}