+%\r
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
+%\r
+\section[RnPat]{Renaming of patterns}\r
+\r
+Basically dependency analysis.\r
+\r
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In\r
+general, all of these functions return a renamed thing, and a set of\r
+free variables.\r
+\r
+\begin{code}\r
+{-# OPTIONS -w #-}\r
+-- The above warning supression flag is a temporary kludge.\r
+-- While working on this module you are encouraged to remove it and fix\r
+-- any warnings in the module. See\r
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings\r
+-- for details\r
+\r
+module RnPat (-- main entry points\r
+ rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,\r
+\r
+ NameMaker, applyNameMaker, -- a utility for making names:\r
+ localNameMaker, topNameMaker, -- sometimes we want to make local names,\r
+ -- sometimes we want to make top (qualified) names.\r
+\r
+ rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor\r
+ --and in an update\r
+\r
+ -- Literals\r
+ rnLit, rnOverLit, \r
+\r
+ -- Pattern Error messages that are also used elsewhere\r
+ checkTupSize, patSigErr\r
+ ) where\r
+\r
+-- ENH: thin imports to only what is necessary for patterns\r
+\r
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts)\r
+\r
+#include "HsVersions.h"\r
+\r
+import HsSyn \r
+import TcRnMonad\r
+import RnEnv\r
+import HscTypes ( availNames )\r
+import RnNames ( getLocalDeclBinders, extendRdrEnvRn )\r
+import RnTypes ( rnHsTypeFVs, \r
+ mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn\r
+ )\r
+import DynFlags ( DynFlag(..) )\r
+import BasicTypes ( FixityDirection(..) )\r
+import SrcLoc ( SrcSpan )\r
+import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,\r
+ loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,\r
+ negateName, thenMName, bindMName, failMName,\r
+ eqClassName, integralClassName, geName, eqName,\r
+ negateName, minusName, lengthPName, indexPName,\r
+ plusIntegerName, fromIntegerName, timesIntegerName,\r
+ ratioDataConName, fromRationalName, fromStringName )\r
+import Constants ( mAX_TUPLE_SIZE )\r
+import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan )\r
+import NameSet\r
+import UniqFM\r
+import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName )\r
+import LoadIface ( loadInterfaceForName )\r
+import UniqFM ( isNullUFM )\r
+import UniqSet ( emptyUniqSet )\r
+import List ( nub )\r
+import Util ( isSingleton )\r
+import ListSetOps ( removeDups, minusList )\r
+import Maybes ( expectJust )\r
+import Outputable\r
+import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc )\r
+import FastString\r
+import Literal ( inIntRange, inCharRange )\r
+import List ( unzip4 )\r
+import Bag (foldrBag)\r
+\r
+import ErrUtils (Message)\r
+\end{code}\r
+\r
+\r
+*********************************************************\r
+* *\r
+\subsection{Patterns}\r
+* *\r
+*********************************************************\r
+\r
+\begin{code}\r
+-- externally abstract type of name makers,\r
+-- which is how you go from a RdrName to a Name\r
+data NameMaker = NM (Located RdrName -> RnM Name)\r
+localNameMaker = NM (\name -> do [newname] <- newLocalsRn [name]\r
+ return newname)\r
+\r
+topNameMaker = NM (\name -> do mod <- getModule\r
+ newTopSrcBinder mod name)\r
+\r
+applyNameMaker :: NameMaker -> Located RdrName -> RnM Name\r
+applyNameMaker (NM f) x = f x\r
+\r
+\r
+-- There are various entry points to renaming patterns, depending on\r
+-- (1) whether the names created should be top-level names or local names\r
+-- (2) whether the scope of the names is entirely given in a continuation\r
+-- (e.g., in a case or lambda, but not in a let or at the top-level,\r
+-- because of the way mutually recursive bindings are handled)\r
+-- (3) whether the type signatures can bind variables\r
+-- (for unpacking existential type vars in data constructors)\r
+-- (4) whether we do duplicate and unused variable checking\r
+-- (5) whether there are fixity declarations associated with the names\r
+-- bound by the patterns that need to be brought into scope with them.\r
+-- \r
+-- Rather than burdening the clients of this module with all of these choices,\r
+-- we export the three points in this design space that we actually need:\r
+\r
+-- entry point 1:\r
+-- binds local names; the scope of the bindings is entirely in the thing_inside\r
+-- allows type sigs to bind vars\r
+-- local namemaker\r
+-- unused and duplicate checking\r
+-- no fixities\r
+rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages\r
+ -> [LPat RdrName] \r
+ -- the continuation gets:\r
+ -- the list of renamed patterns\r
+ -- the (overall) free vars of all of them\r
+ -> (([LPat Name], FreeVars) -> RnM (a, FreeVars))\r
+ -> RnM (a, FreeVars)\r
+\r
+rnPatsAndThen_LocalRightwards ctxt pats thing_inside = \r
+ -- (0) bring into scope all of the type variables bound by the patterns\r
+ bindPatSigTyVarsFV (collectSigTysFromPats pats) $ \r
+ -- (1) rename the patterns, bringing into scope all of the term variables\r
+ rnLPatsAndThen localNameMaker emptyUFM pats $ \ (pats', pat_fvs) ->\r
+ -- (2) then do the thing inside.\r
+ thing_inside (pats', pat_fvs) `thenM` \ (res, res_fvs) ->\r
+ let\r
+ -- walk again to collect the names bound by the pattern\r
+ new_bndrs = collectPatsBinders pats'\r
+\r
+ -- uses now include both pattern uses and thing_inside uses\r
+ used = res_fvs `plusFV` pat_fvs\r
+ unused_binders = filter (not . (`elemNameSet` used)) new_bndrs\r
+\r
+ -- restore the locations and rdrnames of the new_bndrs\r
+ -- lets us use the existing checkDupNames, rather than reimplementing\r
+ -- the error reporting for names\r
+ new_bndrs_rdr = map (\ n -> (L (nameSrcSpan n) \r
+ (mkRdrUnqual (getOccName n)))) new_bndrs\r
+ in \r
+ -- (3) check for duplicates explicitly\r
+ -- (because we don't bind the vars all at once, it doesn't happen\r
+ -- for free in the binding)\r
+ checkDupNames doc_pat new_bndrs_rdr `thenM_`\r
+ -- (4) warn about unused binders\r
+ warnUnusedMatches unused_binders `thenM_`\r
+ -- (5) return; note that the fvs are pruned by the rnLPatsAndThen\r
+ returnM (res, res_fvs `plusFV` pat_fvs)\r
+ where\r
+ doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt\r
+\r
+\r
+-- entry point 2:\r
+-- binds local names; in a recursive scope that involves other bound vars\r
+-- allows type sigs to bind vars\r
+-- local namemaker\r
+-- no unused and duplicate checking\r
+-- fixities might be coming in\r
+rnPat_LocalRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName\r
+ -> RnM (LPat Name, \r
+ -- free variables of the pattern,\r
+ -- but not including variables bound by this pattern \r
+ FreeVars)\r
+\r
+rnPat_LocalRec fix_env pat = \r
+ bindPatSigTyVarsFV (collectSigTysFromPats [pat]) $ \r
+ rnLPatsAndThen localNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
+ return (pat', pat_fvs)\r
+\r
+\r
+-- entry point 3:\r
+-- binds top names; in a recursive scope that involves other bound vars\r
+-- does NOT allow type sigs to bind vars\r
+-- top namemaker\r
+-- no unused and duplicate checking\r
+-- fixities might be coming in\r
+rnPat_TopRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName\r
+ -> RnM (LPat Name, \r
+ -- free variables of the pattern,\r
+ -- but not including variables bound by this pattern \r
+ FreeVars)\r
+\r
+rnPat_TopRec fix_env pat = \r
+ rnLPatsAndThen topNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
+ return (pat', pat_fvs)\r
+\r
+\r
+-- general version: parametrized by how you make new names\r
+-- invariant: what-to-do continuation only gets called with a list whose length is the same as\r
+-- the part of the pattern we're currently renaming\r
+rnLPatsAndThen :: NameMaker -- how to make a new variable\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> [LPat RdrName] -- part of pattern we're currently renaming\r
+ -> (([LPat Name],FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars) -- renaming of the whole thing\r
+ \r
+rnLPatsAndThen var fix_env = mapFvRnCPS (rnLPatAndThen var fix_env)\r
+\r
+\r
+-- the workhorse\r
+rnLPatAndThen :: NameMaker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> LPat RdrName -- part of pattern we're currently renaming\r
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars) -- renaming of the whole thing\r
+rnLPatAndThen var@(NM varf) fix_env (L loc p) cont = \r
+ setSrcSpan loc $ \r
+ let reloc = L loc \r
+ lcont = \ (unlocated, fv) -> cont (reloc unlocated, fv)\r
+\r
+ -- Note: this is somewhat suspicious because it sometimes\r
+ -- binds a top-level name as a local name (when the NameMaker\r
+ -- returns a top-level name).\r
+ -- however, this binding seems to work, and it only exists for\r
+ -- the duration of the patterns and the continuation;\r
+ -- then the top-level name is added to the global env\r
+ -- before going on to the RHSes (see RnSource.lhs).\r
+ --\r
+ -- and doing things this way saves us from having to parametrize\r
+ -- by the environment extender, repeating the FreeVar handling,\r
+ -- etc.\r
+ bind n = bindLocalNamesFV_WithFixities [n] fix_env\r
+ in\r
+ case p of\r
+ WildPat _ -> lcont (WildPat placeHolderType, emptyFVs)\r
+ \r
+ VarPat name -> do\r
+ newBoundName <- varf (reloc name)\r
+ -- we need to bind pattern variables for view pattern expressions\r
+ -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)\r
+ bind newBoundName $ \r
+ (lcont (VarPat newBoundName, emptyFVs))\r
+ \r
+ SigPatIn pat ty ->\r
+ doptM Opt_PatternSignatures `thenM` \ patsigs ->\r
+ if patsigs\r
+ then rnLPatAndThen var fix_env pat\r
+ (\ (pat', fvs1) ->\r
+ rnHsTypeFVs tvdoc ty `thenM` \ (ty', fvs2) ->\r
+ lcont (SigPatIn pat' ty', fvs1 `plusFV` fvs2))\r
+ else addErr (patSigErr ty) `thenM_`\r
+ rnLPatAndThen var fix_env pat cont \r
+ where\r
+ tvdoc = text "In a pattern type-signature"\r
+ \r
+ LitPat lit@(HsString s) -> \r
+ do ovlStr <- doptM Opt_OverloadedStrings\r
+ if ovlStr \r
+ then rnLPatAndThen var fix_env (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont\r
+ else do \r
+ rnLit lit\r
+ lcont (LitPat lit, emptyFVs) -- Same as below\r
+ \r
+ LitPat lit -> do \r
+ rnLit lit\r
+ lcont (LitPat lit, emptyFVs)\r
+\r
+ NPat lit mb_neg eq ->\r
+ rnOverLit lit `thenM` \ (lit', fvs1) ->\r
+ (case mb_neg of\r
+ Nothing -> returnM (Nothing, emptyFVs)\r
+ Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->\r
+ returnM (Just neg, fvs)\r
+ ) `thenM` \ (mb_neg', fvs2) ->\r
+ lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> \r
+ lcont (NPat lit' mb_neg' eq',\r
+ fvs1 `plusFV` fvs2 `plusFV` fvs3) \r
+ -- Needed to find equality on pattern\r
+\r
+ NPlusKPat name lit _ _ -> do\r
+ new_name <- varf name \r
+ bind new_name $ \r
+ rnOverLit lit `thenM` \ (lit', fvs1) ->\r
+ lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->\r
+ lookupSyntaxName geName `thenM` \ (ge, fvs3) ->\r
+ lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus,\r
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)\r
+ -- The Report says that n+k patterns must be in Integral\r
+\r
+ LazyPat pat ->\r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (LazyPat pat', fvs)\r
+\r
+ BangPat pat ->\r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (BangPat pat', fvs)\r
+\r
+ AsPat name pat -> do\r
+ new_name <- varf name \r
+ bind new_name $ \r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> \r
+ lcont (AsPat (L (nameSrcSpan new_name) new_name) pat', fvs)\r
+\r
+ ViewPat expr pat ty -> \r
+ do vp_flag <- doptM Opt_ViewPatterns\r
+ checkErr vp_flag (badViewPat p)\r
+ -- because of the way we're arranging the recursive calls,\r
+ -- this will be in the right context \r
+ (expr', fvExpr) <- rnLExpr expr \r
+ rnLPatAndThen var fix_env pat $ \ (pat', fvPat) ->\r
+ lcont (ViewPat expr' pat' ty, fvPat `plusFV` fvExpr)\r
+\r
+ ConPatIn con stuff -> \r
+ -- rnConPatAndThen takes care of reconstructing the pattern\r
+ rnConPatAndThen var fix_env con stuff cont\r
+\r
+ ParPat pat -> rnLPatAndThen var fix_env pat $ \r
+ \ (pat', fv') -> lcont (ParPat pat', fv')\r
+\r
+ ListPat pats _ -> \r
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (ListPat patslist placeHolderType, fvs)\r
+\r
+ PArrPat pats _ -> \r
+ rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (PArrPat patslist placeHolderType, \r
+ fvs `plusFV` implicit_fvs)\r
+ where\r
+ implicit_fvs = mkFVs [lengthPName, indexPName]\r
+\r
+ TuplePat pats boxed _ -> \r
+ checkTupSize (length pats) `thenM_`\r
+ (rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
+ lcont (TuplePat patslist boxed placeHolderType, fvs))\r
+\r
+ TypePat name -> \r
+ rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->\r
+ lcont (TypePat name', fvs)\r
+\r
+\r
+-- helper for renaming constructor patterns\r
+rnConPatAndThen :: NameMaker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> Located RdrName -- the constructor\r
+ -> HsConPatDetails RdrName \r
+ -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> RnM (a, FreeVars)\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (PrefixCon pats) cont\r
+ = do con' <- lookupLocatedOccRn con\r
+ rnLPatsAndThen var fix_env pats $ \r
+ \ (pats', fvs) -> \r
+ cont (L loc $ ConPatIn con' (PrefixCon pats'),\r
+ fvs `addOneFV` unLoc con')\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (InfixCon pat1 pat2) cont\r
+ = do con' <- lookupLocatedOccRn con\r
+ (rnLPatAndThen var fix_env pat1 $\r
+ (\ (pat1', fvs1) -> \r
+ rnLPatAndThen var fix_env pat2 $ \r
+ (\ (pat2', fvs2) -> do \r
+ fixity <- lookupFixityRn (unLoc con')\r
+ pat' <- mkConOpPatRn con' fixity pat1' pat2'\r
+ cont (L loc pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con'))))\r
+\r
+rnConPatAndThen var fix_env (con@(L loc _)) (RecCon rpats) cont = do\r
+ con' <- lookupLocatedOccRn con\r
+ rnHsRecFieldsAndThen_Pattern con' var fix_env rpats $ \ (rpats', fvs) -> \r
+ cont (L loc $ ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')\r
+\r
+\r
+-- what kind of record expression we're doing\r
+-- the first two tell the name of the datatype constructor in question\r
+-- and give a way of creating a variable to fill in a ..\r
+data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)\r
+ | Pattern (Located Name) (RdrName -> a)\r
+ | Update\r
+\r
+choiceToMessage (Constructor _ _) = "construction"\r
+choiceToMessage (Pattern _ _) = "pattern"\r
+choiceToMessage Update = "update"\r
+\r
+doDotDot (Constructor a b) = Just (a,b)\r
+doDotDot (Pattern a b) = Just (a,b)\r
+doDotDot Update = Nothing\r
+\r
+getChoiceName (Constructor n _) = Just n\r
+getChoiceName (Pattern n _) = Just n\r
+getChoiceName (Update) = Nothing\r
+\r
+\r
+\r
+-- helper for renaming record patterns;\r
+-- parameterized so that it can also be used for expressions\r
+rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field\r
+ -- how to rename the fields (CPSed)\r
+ -> (Located field -> ((Located field', FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)) \r
+ -- the actual fields \r
+ -> HsRecFields RdrName (Located field) \r
+ -- what to do in the scope of the field vars\r
+ -> ((HsRecFields Name (Located field'), FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)\r
+-- Haddock comments for record fields are renamed to Nothing here\r
+rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = \r
+ let\r
+\r
+ -- helper to collect and report duplicate record fields\r
+ reportDuplicateFields doingstr fields = \r
+ let \r
+ -- each list represents a RdrName that occurred more than once\r
+ -- (the list contains all occurrences)\r
+ -- invariant: each list in dup_fields is non-empty\r
+ (_, dup_fields :: [[RdrName]]) = removeDups compare\r
+ (map (unLoc . hsRecFieldId) fields)\r
+ \r
+ -- duplicate field reporting function\r
+ field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group))\r
+ in\r
+ mappM_ field_dup_err dup_fields\r
+\r
+ -- helper to rename each field\r
+ rn_field pun_ok (HsRecField field inside pun) cont = do \r
+ fieldname <- lookupRecordBndr (getChoiceName choice) field\r
+ checkErr (not pun || pun_ok) (badPun field)\r
+ rn_thing inside $ \ (inside', fvs) -> \r
+ cont (HsRecField fieldname inside' pun, \r
+ fvs `addOneFV` unLoc fieldname)\r
+\r
+ -- Compute the extra fields to be filled in by the dot-dot notation\r
+ dot_dot_fields fs con mk_field cont = do \r
+ con_fields <- lookupConstructorFields (unLoc con)\r
+ let missing_fields = con_fields `minusList` fs\r
+ loc <- getSrcSpanM -- Rather approximate\r
+ -- it's important that we make the RdrName fields that we morally wrote\r
+ -- and then rename them in the usual manner\r
+ -- (rather than trying to make the result of renaming directly)\r
+ -- because, for patterns, renaming can bind vars in the continuation\r
+ mapFvRnCPS rn_thing \r
+ (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $\r
+ \ (rhss, fvs_s) -> \r
+ let new_fs = [ HsRecField (L loc f) r False\r
+ | (f, r) <- missing_fields `zip` rhss ]\r
+ in \r
+ cont (new_fs, fvs_s)\r
+\r
+ in do\r
+ -- report duplicate fields\r
+ let doingstr = choiceToMessage choice\r
+ reportDuplicateFields doingstr fields\r
+\r
+ -- rename the records as written\r
+ -- check whether punning (implicit x=x) is allowed\r
+ pun_flag <- doptM Opt_RecordPuns\r
+ -- rename the fields\r
+ mapFvRnCPS (rn_field pun_flag) fields $ \ (fields1, fvs1) ->\r
+\r
+ -- handle ..\r
+ case dd of\r
+ Nothing -> cont (HsRecFields fields1 dd, fvs1)\r
+ Just n -> ASSERT( n == length fields ) do\r
+ dd_flag <- doptM Opt_RecordWildCards\r
+ checkErr dd_flag (needFlagDotDot doingstr)\r
+ let fld_names1 = map (unLoc . hsRecFieldId) fields1\r
+ case doDotDot choice of \r
+ Nothing -> addErr (badDotDot doingstr) `thenM_` \r
+ -- we return a junk value here so that error reporting goes on\r
+ cont (HsRecFields fields1 dd, fvs1)\r
+ Just (con, mk_field) ->\r
+ dot_dot_fields fld_names1 con mk_field $\r
+ \ (fields2, fvs2) -> \r
+ cont (HsRecFields (fields1 ++ fields2) dd, \r
+ fvs1 `plusFV` fvs2)\r
+\r
+needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,\r
+ ptext SLIT("Use -XRecordWildCards to permit this")]\r
+\r
+badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str\r
+\r
+badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),\r
+ ptext SLIT("Use -XRecordPuns to permit this")]\r
+\r
+\r
+-- wrappers\r
+rnHsRecFieldsAndThen_Pattern :: Located Name\r
+ -> NameMaker -- new name maker\r
+ -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> HsRecFields RdrName (LPat RdrName) \r
+ -> ((HsRecFields Name (LPat Name), FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars)\r
+rnHsRecFieldsAndThen_Pattern n var fix_env = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var fix_env)\r
+\r
+\r
+-- wrapper to use rnLExpr in CPS style;\r
+-- because it does not bind any vars going forward, it does not need\r
+-- to be written that way\r
+rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> LHsExpr RdrName \r
+ -> ((LHsExpr Name, FreeVars) -> RnM (c, FreeVars)) \r
+ -> RnM (c, FreeVars) \r
+rnLExprAndThen f e cont = do {x <- f e; cont x}\r
+\r
+\r
+-- non-CPSed because exprs don't leave anything bound\r
+rnHsRecFields_Con :: Located Name\r
+ -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> HsRecFields RdrName (LHsExpr RdrName) \r
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
+rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar) \r
+ (rnLExprAndThen rnLExpr) fields return\r
+\r
+rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
+ -> HsRecFields RdrName (LHsExpr RdrName) \r
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
+rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update\r
+ (rnLExprAndThen rnLExpr) fields return\r
+\end{code}\r
+\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection{Literals}\r
+%* *\r
+%************************************************************************\r
+\r
+When literals occur we have to make sure\r
+that the types and classes they involve\r
+are made available.\r
+\r
+\begin{code}\r
+rnLit :: HsLit -> RnM ()\r
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)\r
+rnLit other = returnM ()\r
+\r
+rnOverLit (HsIntegral i _ _)\r
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->\r
+ if inIntRange i then\r
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs)\r
+ else let\r
+ extra_fvs = mkFVs [plusIntegerName, timesIntegerName]\r
+ -- Big integer literals are built, using + and *, \r
+ -- out of small integers (DsUtils.mkIntegerLit)\r
+ -- [NB: plusInteger, timesInteger aren't rebindable... \r
+ -- they are used to construct the argument to fromInteger, \r
+ -- which is the rebindable one.]\r
+ in\r
+ returnM (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs)\r
+\r
+rnOverLit (HsFractional i _ _)\r
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->\r
+ let\r
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]\r
+ -- We have to make sure that the Ratio type is imported with\r
+ -- its constructor, because literals of type Ratio t are\r
+ -- built with that constructor.\r
+ -- The Rational type is needed too, but that will come in\r
+ -- as part of the type for fromRational.\r
+ -- The plus/times integer operations may be needed to construct the numerator\r
+ -- and denominator (see DsUtils.mkIntegerLit)\r
+ in\r
+ returnM (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs)\r
+\r
+rnOverLit (HsIsString s _ _)\r
+ = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) ->\r
+ returnM (HsIsString s from_string_name placeHolderType, fvs)\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection{Errors}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+checkTupSize :: Int -> RnM ()\r
+checkTupSize tup_size\r
+ | tup_size <= mAX_TUPLE_SIZE \r
+ = returnM ()\r
+ | otherwise \r
+ = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),\r
+ nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),\r
+ nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])\r
+\r
+patSigErr ty\r
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)\r
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))\r
+\r
+dupFieldErr str dup\r
+ = hsep [ptext SLIT("duplicate field name"), \r
+ quotes (ppr dup),\r
+ ptext SLIT("in record"), text str]\r
+\r
+bogusCharError c\r
+ = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''\r
+\r
+badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat,\r
+ ptext SLIT("Use -XViewPatterns to enalbe view patterns")]\r
+\r
+\end{code}\r