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,
-- 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}
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
-> 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:
-- 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"
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)
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
; (res, fvs2) <- lcont (TypePat name')
; return (res, fvs1 `plusFV` fvs2) }
+ p -> pprPanic "rnLPatAndThen" (ppr p)
+
-- helper for renaming constructor patterns
rnConPatAndThen :: NameMaker
| 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
-- 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
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
\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
-- 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}
%************************************************************************
%* *
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}
projects / ghc-hetmet.git / blobdiff