-%\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 a type signature in the pattern can bind \r
--- lexically-scoped type variables (for unpacking existential \r
--- 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 type 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
--- e.g let { (x, Just y) = e1; ... } in ...\r
--- does NOT allows type sig to bind type 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
- 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 -XPatternSignatures 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
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[RnPat]{Renaming of patterns}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+
+\begin{code}
+module RnPat (-- main entry points
+ rnPat, rnPats, rnBindPat,
+
+ NameMaker, applyNameMaker, -- a utility for making names:
+ localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
+ -- sometimes we want to make top (qualified) names.
+
+ rnHsRecFields1, HsRecFieldContext(..),
+
+ -- Literals
+ rnLit, rnOverLit,
+
+ -- 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 )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
+#endif /* GHCI */
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcRnMonad
+import TcHsSyn ( hsOverLitName )
+import RnEnv
+import RnTypes
+import DynFlags
+import PrelNames
+import Constants ( mAX_TUPLE_SIZE )
+import Name
+import NameSet
+import RdrName
+import BasicTypes
+import ListSetOps ( removeDups, minusList )
+import Outputable
+import SrcLoc
+import FastString
+import Literal ( inCharRange )
+import Control.Monad ( when )
+\end{code}
+
+
+%*********************************************************
+%* *
+ The CpsRn Monad
+%* *
+%*********************************************************
+
+Note [CpsRn monad]
+~~~~~~~~~~~~~~~~~~
+The CpsRn monad uses continuation-passing style to support this
+style of programming:
+
+ do { ...
+ ; ns <- bindNames rs
+ ; ...blah... }
+
+ where rs::[RdrName], ns::[Name]
+
+The idea is that '...blah...'
+ a) sees the bindings of ns
+ b) returns the free variables it mentions
+ so that bindNames can report unused ones
+
+In particular,
+ mapM rnPatAndThen [p1, p2, p3]
+has a *left-to-right* scoping: it makes the binders in
+p1 scope over p2,p3.
+
+\begin{code}
+newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
+ -> RnM (r, FreeVars) }
+ -- See Note [CpsRn monad]
+
+instance Monad CpsRn where
+ return x = CpsRn (\k -> k x)
+ (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
+
+runCps :: CpsRn a -> RnM (a, FreeVars)
+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
+
+liftCps :: RnM a -> CpsRn a
+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
+
+liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
+ ; (r,fvs2) <- k v
+ ; return (r, fvs1 `plusFV` fvs2) })
+
+wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
+-- Set the location, and also wrap it around the value returned
+wrapSrcSpanCps fn (L loc a)
+ = CpsRn (\k -> setSrcSpan loc $
+ unCpsRn (fn a) $ \v ->
+ k (L loc v))
+
+lookupConCps :: Located RdrName -> CpsRn (Located Name)
+lookupConCps con_rdr
+ = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
+ ; (r, fvs) <- k con_name
+ ; return (r, fvs `plusFV` unitFV (unLoc con_name)) })
+\end{code}
+
+%*********************************************************
+%* *
+ Name makers
+%* *
+%*********************************************************
+
+Externally abstract type of name makers,
+which is how you go from a RdrName to a Name
+
+\begin{code}
+data NameMaker
+ = LamMk -- Lambdas
+ Bool -- True <=> report unused bindings
+ -- (even if True, the warning only comes out
+ -- if -fwarn-unused-matches is on)
+
+ | LetMk -- Let bindings, incl top level
+ -- Do *not* check for unused bindings
+ TopLevelFlag
+ MiniFixityEnv
+
+topRecNameMaker :: MiniFixityEnv -> NameMaker
+topRecNameMaker fix_env = LetMk TopLevel fix_env
+
+localRecNameMaker :: MiniFixityEnv -> NameMaker
+localRecNameMaker fix_env = LetMk NotTopLevel fix_env
+
+matchNameMaker :: HsMatchContext a -> NameMaker
+matchNameMaker ctxt = LamMk report_unused
+ where
+ -- Do not report unused names in interactive contexts
+ -- i.e. when you type 'x <- e' at the GHCi prompt
+ report_unused = case ctxt of
+ StmtCtxt GhciStmt -> False
+ _ -> True
+
+newName :: NameMaker -> Located RdrName -> CpsRn Name
+newName (LamMk report_unused) rdr_name
+ = CpsRn (\ thing_inside ->
+ do { name <- newLocalBndrRn rdr_name
+ ; (res, fvs) <- bindLocalName name (thing_inside name)
+ ; when report_unused $ warnUnusedMatches [name] fvs
+ ; return (res, name `delFV` fvs) })
+
+newName (LetMk is_top fix_env) rdr_name
+ = CpsRn (\ thing_inside ->
+ do { name <- case is_top of
+ NotTopLevel -> newLocalBndrRn rdr_name
+ TopLevel -> newTopSrcBinder rdr_name
+ ; bindLocalName name $ -- Do *not* use bindLocalNameFV here
+ -- See Note [View pattern usage]
+ addLocalFixities fix_env [name] $
+ thing_inside name })
+
+ -- Note: the bindLocalName is somewhat suspicious
+ -- because it binds a top-level name as a local name.
+ -- however, this binding seems to work, and it only exists for
+ -- the duration of the patterns and the continuation;
+ -- then the top-level name is added to the global env
+ -- before going on to the RHSes (see RnSource.lhs).
+\end{code}
+
+Note [View pattern usage]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ let (r, (r -> x)) = x in ...
+Here the pattern binds 'r', and then uses it *only* in the view pattern.
+We want to "see" this use, and in let-bindings we collect all uses and
+report unused variables at the binding level. So we must use bindLocalName
+here, *not* bindLocalNameFV. Trac #3943.
+
+%*********************************************************
+%* *
+ External entry points
+%* *
+%*********************************************************
+
+There are various entry points to renaming patterns, depending on
+ (1) whether the names created should be top-level names or local names
+ (2) whether the scope of the names is entirely given in a continuation
+ (e.g., in a case or lambda, but not in a let or at the top-level,
+ because of the way mutually recursive bindings are handled)
+ (3) whether the a type signature in the pattern can bind
+ lexically-scoped type variables (for unpacking existential
+ type vars in data constructors)
+ (4) whether we do duplicate and unused variable checking
+ (5) whether there are fixity declarations associated with the names
+ bound by the patterns that need to be brought into scope with them.
+
+ Rather than burdening the clients of this module with all of these choices,
+ we export the three points in this design space that we actually need:
+
+\begin{code}
+-- ----------- Entry point 1: rnPats -------------------
+-- Binds local names; the scope of the bindings is entirely in the thing_inside
+-- * allows type sigs to bind type vars
+-- * local namemaker
+-- * unused and duplicate checking
+-- * no fixities
+rnPats :: HsMatchContext Name -- for error messages
+ -> [LPat RdrName]
+ -> ([LPat Name] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rnPats ctxt pats thing_inside
+ = 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) $
+ unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) 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'
+ ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names
+ ; thing_inside pats' } }
+ where
+ doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt
+
+rnPat :: HsMatchContext Name -- for error messages
+ -> LPat RdrName
+ -> (LPat Name -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars) -- Variables bound by pattern do not
+ -- appear in the result FreeVars
+rnPat ctxt pat thing_inside
+ = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
+
+applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
+
+-- ----------- Entry point 2: rnBindPat -------------------
+-- Binds local names; in a recursive scope that involves other bound vars
+-- e.g let { (x, Just y) = e1; ... } in ...
+-- * does NOT allows type sig to bind type vars
+-- * local namemaker
+-- * no unused and duplicate checking
+-- * fixities might be coming in
+rnBindPat :: NameMaker
+ -> LPat RdrName
+ -> RnM (LPat Name, FreeVars)
+ -- Returned FreeVars are the free variables of the pattern,
+ -- of course excluding variables bound by this pattern
+
+rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
+\end{code}
+
+
+%*********************************************************
+%* *
+ The main event
+%* *
+%*********************************************************
+
+\begin{code}
+-- ----------- Entry point 3: rnLPatAndThen -------------------
+-- General version: parametrized by how you make new names
+
+rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name]
+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
+ -- Despite the map, the monad ensures that each pattern binds
+ -- variables that may be mentioned in subsequent patterns in the list
+
+--------------------
+-- The workhorse
+rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name)
+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
+
+rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name)
+rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType)
+rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
+rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
+rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
+rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM
+ ; name <- newName mk (L loc rdr)
+ ; return (VarPat name) }
+ -- 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)
+
+rnPatAndThen mk (SigPatIn pat ty)
+ = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
+ ; if patsigs
+ then do { pat' <- rnLPatAndThen mk pat
+ ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
+ ; return (SigPatIn pat' ty') }
+ else do { liftCps (addErr (patSigErr ty))
+ ; rnPatAndThen mk (unLoc pat) } }
+ where
+ tvdoc = text "In a pattern type-signature"
+
+rnPatAndThen mk (LitPat lit)
+ | HsString s <- lit
+ = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings)
+ ; if ovlStr
+ then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing)
+ else normal_lit }
+ | otherwise = normal_lit
+ where
+ normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
+
+rnPatAndThen _ (NPat lit mb_neg _eq)
+ = do { lit' <- liftCpsFV $ rnOverLit lit
+ ; mb_neg' <- liftCpsFV $ case mb_neg of
+ Nothing -> return (Nothing, emptyFVs)
+ Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName
+ ; return (Just neg, fvs) }
+ ; eq' <- liftCpsFV $ lookupSyntaxName eqName
+ ; return (NPat lit' mb_neg' eq') }
+
+rnPatAndThen mk (NPlusKPat rdr lit _ _)
+ = do { new_name <- newName mk rdr
+ ; lit' <- liftCpsFV $ rnOverLit lit
+ ; minus <- liftCpsFV $ lookupSyntaxName minusName
+ ; ge <- liftCpsFV $ lookupSyntaxName geName
+ ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) }
+ -- The Report says that n+k patterns must be in Integral
+
+rnPatAndThen mk (AsPat rdr pat)
+ = do { new_name <- newName mk rdr
+ ; pat' <- rnLPatAndThen mk pat
+ ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
+
+rnPatAndThen mk p@(ViewPat expr pat ty)
+ = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns
+ ; checkErr vp_flag (badViewPat p) }
+ -- Because of the way we're arranging the recursive calls,
+ -- this will be in the right context
+ ; expr' <- liftCpsFV $ rnLExpr expr
+ ; pat' <- rnLPatAndThen mk pat
+ ; return (ViewPat expr' pat' ty) }
+
+rnPatAndThen mk (ConPatIn con stuff)
+ -- rnConPatAndThen takes care of reconstructing the pattern
+ = rnConPatAndThen mk con stuff
+
+rnPatAndThen mk (ListPat pats _)
+ = do { pats' <- rnLPatsAndThen mk pats
+ ; return (ListPat pats' placeHolderType) }
+
+rnPatAndThen mk (PArrPat pats _)
+ = do { pats' <- rnLPatsAndThen mk pats
+ ; return (PArrPat pats' placeHolderType) }
+
+rnPatAndThen mk (TuplePat pats boxed _)
+ = do { liftCps $ checkTupSize (length pats)
+ ; pats' <- rnLPatsAndThen mk pats
+ ; return (TuplePat pats' boxed placeHolderType) }
+
+#ifndef GHCI
+rnPatAndThen _ p@(QuasiQuotePat {})
+ = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
+#else
+rnPatAndThen mk (QuasiQuotePat qq)
+ = do { pat <- liftCps $ runQuasiQuotePat qq
+ ; L _ pat' <- rnLPatAndThen mk pat
+ ; return pat' }
+#endif /* GHCI */
+
+rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
+
+
+--------------------
+rnConPatAndThen :: NameMaker
+ -> Located RdrName -- the constructor
+ -> HsConPatDetails RdrName
+ -> CpsRn (Pat Name)
+
+rnConPatAndThen mk con (PrefixCon pats)
+ = do { con' <- lookupConCps con
+ ; pats' <- rnLPatsAndThen mk pats
+ ; return (ConPatIn con' (PrefixCon pats')) }
+
+rnConPatAndThen mk con (InfixCon pat1 pat2)
+ = do { con' <- lookupConCps con
+ ; pat1' <- rnLPatAndThen mk pat1
+ ; pat2' <- rnLPatAndThen mk pat2
+ ; fixity <- liftCps $ lookupFixityRn (unLoc con')
+ ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
+
+rnConPatAndThen mk con (RecCon rpats)
+ = do { con' <- lookupConCps con
+ ; rpats' <- rnHsRecPatsAndThen mk con' rpats
+ ; return (ConPatIn con' (RecCon rpats')) }
+
+--------------------
+rnHsRecPatsAndThen :: NameMaker
+ -> Located Name -- Constructor
+ -> HsRecFields RdrName (LPat RdrName)
+ -> CpsRn (HsRecFields Name (LPat Name))
+rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
+ = do { flds <- liftCpsFV $ rnHsRecFields1 (HsRecFieldPat con) VarPat hs_rec_fields
+ ; flds' <- mapM rn_field (flds `zip` [1..])
+ ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
+ where
+ rn_field (fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
+ (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldArg = arg' }) }
+
+ -- Suppress unused-match reporting for fields introduced by ".."
+ nested_mk Nothing mk _ = mk
+ nested_mk (Just _) mk@(LetMk {}) _ = mk
+ nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
+\end{code}
+
+
+%************************************************************************
+%* *
+ Record fields
+%* *
+%************************************************************************
+
+\begin{code}
+data HsRecFieldContext
+ = HsRecFieldCon Name
+ | HsRecFieldPat Name
+ | HsRecFieldUpd
+
+rnHsRecFields1
+ :: HsRecFieldContext
+ -> (RdrName -> arg) -- When punning, use this to build a new field
+ -> HsRecFields RdrName (Located arg)
+ -> RnM ([HsRecField Name (Located arg)], FreeVars)
+
+-- This supprisingly complicated pass
+-- a) looks up the field name (possibly using disambiguation)
+-- b) fills in puns and dot-dot stuff
+-- When we we've finished, we've renamed the LHS, but not the RHS,
+-- of each x=e binding
+
+rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
+ = do { pun_ok <- xoptM Opt_RecordPuns
+ ; disambig_ok <- xoptM Opt_DisambiguateRecordFields
+ ; parent <- check_disambiguation disambig_ok mb_con
+ ; flds1 <- mapM (rn_fld pun_ok parent) flds
+ ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
+ ; flds2 <- rn_dotdot dotdot mb_con flds1
+ ; return (flds2, mkFVs (getFieldIds flds2)) }
+ where
+ mb_con = case ctxt of
+ HsRecFieldUpd -> Nothing
+ HsRecFieldCon con -> Just con
+ HsRecFieldPat con -> Just con
+ doc = case mb_con of
+ Nothing -> ptext (sLit "constructor field name")
+ Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
+
+ name_to_arg (L loc n) = L loc (mk_arg (mkRdrUnqual (nameOccName n)))
+
+ rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
+ , hsRecFieldArg = arg
+ , hsRecPun = pun })
+ = do { fld' <- wrapLocM (lookupSubBndr parent doc) fld
+ ; arg' <- if pun
+ then do { checkErr pun_ok (badPun fld)
+ ; return (name_to_arg fld') }
+ else return arg
+ ; return (HsRecField { hsRecFieldId = fld'
+ , hsRecFieldArg = arg'
+ , hsRecPun = pun }) }
+
+ rn_dotdot Nothing _mb_con flds -- No ".." at all
+ = return flds
+ rn_dotdot (Just {}) Nothing flds -- ".." on record update
+ = do { addErr (badDotDot ctxt); return flds }
+ rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat
+ = ASSERT( n == length flds )
+ do { loc <- getSrcSpanM -- Rather approximate
+ ; dd_flag <- xoptM Opt_RecordWildCards
+ ; checkErr dd_flag (needFlagDotDot ctxt)
+
+ ; con_fields <- lookupConstructorFields con
+ ; let present_flds = getFieldIds flds
+ absent_flds = con_fields `minusList` present_flds
+ extras = [ HsRecField
+ { hsRecFieldId = L loc f
+ , hsRecFieldArg = name_to_arg (L loc f)
+ , hsRecPun = False }
+ | f <- absent_flds ]
+
+ ; return (flds ++ extras) }
+
+ check_disambiguation :: Bool -> Maybe Name -> RnM Parent
+ -- When disambiguation is on, return the parent *type constructor*
+ -- That is, the parent of the data constructor. That's the parent
+ -- to use for looking up record fields.
+ check_disambiguation disambig_ok mb_con
+ | disambig_ok, Just con <- mb_con
+ = do { env <- getGlobalRdrEnv
+ ; return (case lookupGRE_Name env con of
+ [gre] -> gre_par gre
+ gres -> WARN( True, ppr con <+> ppr gres ) NoParent) }
+ | otherwise = return NoParent
+
+ dup_flds :: [[RdrName]]
+ -- Each list represents a RdrName that occurred more than once
+ -- (the list contains all occurrences)
+ -- Each list in dup_fields is non-empty
+ (_, dup_flds) = removeDups compare (getFieldIds flds)
+
+getFieldIds :: [HsRecField id arg] -> [id]
+getFieldIds flds = map (unLoc . hsRecFieldId) flds
+
+needFlagDotDot :: HsRecFieldContext -> SDoc
+needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
+ ptext (sLit "Use -XRecordWildCards to permit this")]
+
+badDotDot :: HsRecFieldContext -> SDoc
+badDotDot ctxt = ptext (sLit "You cannot use `..' in a record") <+> pprRFC ctxt
+
+badPun :: Located RdrName -> SDoc
+badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld),
+ ptext (sLit "Use -XNamedFieldPuns to permit this")]
+
+dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
+dupFieldErr ctxt dups
+ = hsep [ptext (sLit "duplicate field name"),
+ quotes (ppr (head dups)),
+ ptext (sLit "in record"), pprRFC ctxt]
+
+pprRFC :: HsRecFieldContext -> SDoc
+pprRFC (HsRecFieldCon {}) = ptext (sLit "construction")
+pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern")
+pprRFC (HsRecFieldUpd {}) = ptext (sLit "update")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Literals}
+%* *
+%************************************************************************
+
+When literals occur we have to make sure
+that the types and classes they involve
+are made available.
+
+\begin{code}
+rnLit :: HsLit -> RnM ()
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit _ = return ()
+
+rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
+rnOverLit lit@(OverLit {ol_val=val})
+ = do { let std_name = hsOverLitName val
+ ; (from_thing_name, fvs) <- lookupSyntaxName std_name
+ ; let rebindable = case from_thing_name of
+ HsVar v -> v /= std_name
+ _ -> panic "rnOverLit"
+ ; return (lit { ol_witness = from_thing_name
+ , ol_rebindable = rebindable }, fvs) }
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Errors}
+%* *
+%************************************************************************
+
+\begin{code}
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+ | tup_size <= mAX_TUPLE_SIZE
+ = 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"))])
+
+patSigErr :: Outputable a => a -> SDoc
+patSigErr ty
+ = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext (sLit "Use -XScopedTypeVariables to permit it"))
+
+bogusCharError :: Char -> SDoc
+bogusCharError c
+ = ptext (sLit "character literal out of range: '\\") <> char c <> char '\''
+
+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