-%\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, rnBindPat,\r
-\r
- NameMaker, applyNameMaker, -- a utility for making names:\r
- localRecNameMaker, topRecNameMaker, -- 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 (forall a. Located RdrName -> (Name -> RnM (a, FreeVars))\r
- -> RnM (a, FreeVars))\r
-\r
-matchNameMaker :: NameMaker\r
-matchNameMaker\r
- = NM (\ rdr_name thing_inside -> \r
- do { names@[name] <- newLocalsRn [rdr_name]\r
- ; bindLocalNamesFV names $\r
- warnUnusedMatches names $\r
- thing_inside name })\r
- \r
-topRecNameMaker, localRecNameMaker\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
- -> NameMaker\r
-\r
--- topNameMaker and localBindMaker do not check for unused binding\r
-localRecNameMaker fix_env\r
- = NM (\ rdr_name thing_inside -> \r
- do { [name] <- newLocalsRn [rdr_name]\r
- ; bindLocalNamesFV_WithFixities [name] fix_env $\r
- thing_inside name })\r
- \r
-topRecNameMaker fix_env\r
- = NM (\rdr_name thing_inside -> \r
- do { mod <- getModule\r
- ; name <- newTopSrcBinder mod rdr_name\r
- ; bindLocalNamesFV_WithFixities [name] fix_env $\r
- thing_inside name })\r
- -- Note: the bindLocalNamesFV_WithFixities is somewhat suspicious \r
- -- because it binds a top-level name as a local 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
-applyNameMaker :: NameMaker -> Located RdrName\r
- -> (Name -> RnM (a,FreeVars)) -> RnM (a, FreeVars)\r
-applyNameMaker (NM f) = f\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] -> RnM (a, FreeVars))\r
- -> RnM (a, FreeVars)\r
-\r
-rnPatsAndThen_LocalRightwards ctxt pats thing_inside\r
- = do { -- Check for duplicated and shadowed names \r
- -- Because we don't bind the vars all at once, we can't\r
- -- check incrementally for duplicates; \r
- -- Nor can we check incrementally for shadowing, else we'll\r
- -- complain *twice* about duplicates e.g. f (x,x) = ...\r
- let rdr_names_w_loc = collectLocatedPatsBinders pats\r
- ; checkDupNames doc_pat rdr_names_w_loc\r
- ; checkShadowing doc_pat rdr_names_w_loc\r
-\r
- -- (0) bring into scope all of the type variables bound by the patterns\r
- -- (1) rename the patterns, bringing into scope all of the term variables\r
- -- (2) then do the thing inside.\r
- ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ \r
- rnLPatsAndThen matchNameMaker pats $\r
- thing_inside }\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
-rnBindPat :: NameMaker\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
-rnBindPat name_maker pat\r
- = rnLPatsAndThen name_maker [pat] $ \ [pat'] ->\r
- return (pat', emptyFVs)\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
- -> [LPat RdrName] -- part of pattern we're currently renaming\r
- -> ([LPat Name] -> RnM (a, FreeVars)) -- what to do afterwards\r
- -> RnM (a, FreeVars) -- renaming of the whole thing\r
- \r
-rnLPatsAndThen var = mapFvRnCPS (rnLPatAndThen var)\r
-\r
-\r
--- the workhorse\r
-rnLPatAndThen :: NameMaker\r
- -> LPat RdrName -- part of pattern we're currently renaming\r
- -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards\r
- -> RnM (a, FreeVars) -- renaming of the whole thing\r
-rnLPatAndThen var@(NM varf) (L loc p) cont = \r
- setSrcSpan loc $ \r
- let reloc = L loc \r
- lcont = \ unlocated -> cont (reloc unlocated)\r
- in\r
- case p of\r
- WildPat _ -> lcont (WildPat placeHolderType)\r
-\r
- ParPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (ParPat pat')\r
- LazyPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (LazyPat pat')\r
- BangPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (BangPat pat')\r
- \r
- VarPat name -> \r
- varf (reloc name) $ \ newBoundName -> \r
- lcont (VarPat newBoundName)\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
- \r
- SigPatIn pat ty ->\r
- doptM Opt_PatternSignatures `thenM` \ patsigs ->\r
- if patsigs\r
- then rnLPatAndThen var pat\r
- (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty\r
- ; (res, fvs2) <- lcont (SigPatIn pat' ty')\r
- ; return (res, fvs1 `plusFV` fvs2) })\r
- else addErr (patSigErr ty) `thenM_`\r
- rnLPatAndThen var 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 (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont\r
- else do { rnLit lit; lcont (LitPat lit) } -- Same as below\r
- \r
- LitPat lit -> do { rnLit lit; lcont (LitPat lit) }\r
-\r
- NPat lit mb_neg eq ->\r
- do { (lit', fvs1) <- rnOverLit lit\r
- ; (mb_neg', fvs2) <- case mb_neg of\r
- Nothing -> return (Nothing, emptyFVs)\r
- Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName\r
- ; return (Just neg, fvs) }\r
- ; (eq', fvs3) <- lookupSyntaxName eqName\r
- ; (res, fvs4) <- lcont (NPat lit' mb_neg' eq')\r
- ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }\r
- -- Needed to find equality on pattern\r
-\r
- NPlusKPat name lit _ _ ->\r
- varf name $ \ new_name ->\r
- do { (lit', fvs1) <- rnOverLit lit\r
- ; (minus, fvs2) <- lookupSyntaxName minusName\r
- ; (ge, fvs3) <- lookupSyntaxName geName\r
- ; (res, fvs4) <- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus)\r
- ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }\r
- -- The Report says that n+k patterns must be in Integral\r
-\r
- AsPat name pat ->\r
- varf name $ \ new_name ->\r
- rnLPatAndThen var pat $ \ pat' -> \r
- lcont (AsPat (L (nameSrcSpan new_name) new_name) pat')\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', fv_expr) <- rnLExpr expr \r
- ; (res, fvs_res) <- rnLPatAndThen var pat $ \ pat' ->\r
- lcont (ViewPat expr' pat' ty)\r
- ; return (res, fvs_res `plusFV` fv_expr) }\r
-\r
- ConPatIn con stuff -> \r
- -- rnConPatAndThen takes care of reconstructing the pattern\r
- rnConPatAndThen var con stuff cont\r
-\r
- ListPat pats _ -> \r
- rnLPatsAndThen var pats $ \ patslist ->\r
- lcont (ListPat patslist placeHolderType)\r
-\r
- PArrPat pats _ -> \r
- do { (res, res_fvs) <- rnLPatsAndThen var pats $ \ patslist ->\r
- lcont (PArrPat patslist placeHolderType)\r
- ; return (res, res_fvs `plusFV` implicit_fvs) }\r
- where\r
- implicit_fvs = mkFVs [lengthPName, indexPName]\r
-\r
- TuplePat pats boxed _ -> \r
- do { checkTupSize (length pats)\r
- ; rnLPatsAndThen var pats $ \ patslist ->\r
- lcont (TuplePat patslist boxed placeHolderType) }\r
-\r
- TypePat name -> \r
- do { (name', fvs1) <- rnHsTypeFVs (text "In a type pattern") name\r
- ; (res, fvs2) <- lcont (TypePat name')\r
- ; return (res, fvs1 `plusFV` fvs2) }\r
-\r
-\r
--- helper for renaming constructor patterns\r
-rnConPatAndThen :: NameMaker\r
- -> Located RdrName -- the constructor\r
- -> HsConPatDetails RdrName \r
- -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards\r
- -> RnM (a, FreeVars)\r
-\r
-rnConPatAndThen var (con@(L loc _)) (PrefixCon pats) cont\r
- = do { con' <- lookupLocatedOccRn con\r
- ; (res, res_fvs) <- rnLPatsAndThen var pats $ \ pats' ->\r
- cont (L loc $ ConPatIn con' (PrefixCon pats'))\r
- ; return (res, res_fvs `addOneFV` unLoc con') }\r
-\r
-rnConPatAndThen var (con@(L loc _)) (InfixCon pat1 pat2) cont\r
- = do { con' <- lookupLocatedOccRn con\r
- ; (res, res_fvs) <- rnLPatAndThen var pat1 $ \ pat1' -> \r
- rnLPatAndThen var pat2 $ \ pat2' ->\r
- do { fixity <- lookupFixityRn (unLoc con')\r
- ; pat' <- mkConOpPatRn con' fixity pat1' pat2'\r
- ; cont (L loc pat') }\r
- ; return (res, res_fvs `addOneFV` unLoc con') }\r
-\r
-rnConPatAndThen var (con@(L loc _)) (RecCon rpats) cont\r
- = do { con' <- lookupLocatedOccRn con\r
- ; (res, res_fvs) <- rnHsRecFieldsAndThen_Pattern con' var rpats $ \ rpats' -> \r
- cont (L loc $ ConPatIn con' (RecCon rpats'))\r
- ; return (res, res_fvs `addOneFV` unLoc con') }\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' -> 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') -> 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
- (res, res_fvs) <- rn_thing inside $ \ inside' -> \r
- cont (HsRecField fieldname inside' pun) \r
- return (res, res_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 -> \r
- let new_fs = [ HsRecField (L loc f) r False\r
- | (f, r) <- missing_fields `zip` rhss ]\r
- in \r
- cont new_fs\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 ->\r
-\r
- -- handle ..\r
- case dd of\r
- Nothing -> cont (HsRecFields fields1 dd)\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)\r
- Just (con, mk_field) ->\r
- dot_dot_fields fld_names1 con mk_field $\r
- \ fields2 -> \r
- cont (HsRecFields (fields1 ++ fields2) dd)\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
- -> HsRecFields RdrName (LPat RdrName) \r
- -> (HsRecFields Name (LPat Name) -> RnM (c, FreeVars)) \r
- -> RnM (c, FreeVars)\r
-rnHsRecFieldsAndThen_Pattern n var\r
- = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var)\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 -> RnM (c, FreeVars)) \r
- -> RnM (c, FreeVars) \r
-rnLExprAndThen f e cont = do { (x, fvs1) <- f e\r
- ; (res, fvs2) <- cont x\r
- ; return (res, fvs1 `plusFV` fvs2) }\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 $ \ res ->\r
- return (res, emptyFVs)\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 $ \ res -> \r
- return (res, emptyFVs)\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}
+{-# 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,
+
+ NameMaker, applyNameMaker, -- a utility for making names:
+ localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
+ -- sometimes we want to make top (qualified) names.
+
+ rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor
+ --and in an update
+
+ -- 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, rnStmts)
+
+#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 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 Constants ( mAX_TUPLE_SIZE )
+import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan )
+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 ListSetOps ( removeDups, minusList )
+import Maybes ( expectJust )
+import Outputable
+import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc )
+import FastString
+import Literal ( inIntRange, inCharRange )
+import List ( unzip4 )
+import Bag (foldrBag)
+
+import ErrUtils (Message)
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Patterns}
+* *
+*********************************************************
+
+\begin{code}
+-- externally abstract type of name makers,
+-- which is how you go from a RdrName to a Name
+data NameMaker = NM (forall a. Located RdrName -> (Name -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars))
+
+matchNameMaker :: NameMaker
+matchNameMaker
+ = NM (\ rdr_name thing_inside ->
+ do { names@[name] <- newLocalsRn [rdr_name]
+ ; bindLocalNamesFV names $
+ warnUnusedMatches names $
+ thing_inside name })
+
+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
+
+-- topNameMaker and localBindMaker do not check for unused binding
+localRecNameMaker fix_env
+ = NM (\ rdr_name thing_inside ->
+ do { [name] <- newLocalsRn [rdr_name]
+ ; bindLocalNamesFV_WithFixities [name] fix_env $
+ thing_inside name })
+
+topRecNameMaker fix_env
+ = NM (\rdr_name thing_inside ->
+ do { mod <- getModule
+ ; name <- newTopSrcBinder mod rdr_name
+ ; bindLocalNamesFV_WithFixities [name] fix_env $
+ thing_inside name })
+ -- Note: the bindLocalNamesFV_WithFixities 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).
+
+applyNameMaker :: NameMaker -> Located RdrName
+ -> (Name -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
+applyNameMaker (NM f) = f
+
+
+-- 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:
+
+-- entry point 1:
+-- 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
+rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages
+ -> [LPat RdrName]
+ -- the continuation gets:
+ -- the list of renamed patterns
+ -- the (overall) free vars of all of them
+ -> ([LPat Name] -> RnM (a, FreeVars))
+ -> 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
+
+ -- (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 }
+ where
+ doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt
+
+
+-- entry point 2:
+-- 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,
+ -- free variables of the pattern,
+ -- but not including variables bound by this pattern
+ FreeVars)
+
+rnBindPat name_maker pat
+ = rnLPatsAndThen name_maker [pat] $ \ [pat'] ->
+ return (pat', emptyFVs)
+
+
+-- general version: parametrized by how you make new names
+-- invariant: what-to-do continuation only gets called with a list whose length is the same as
+-- the part of the pattern we're currently renaming
+rnLPatsAndThen :: NameMaker -- how to make a new variable
+ -> [LPat RdrName] -- part of pattern we're currently renaming
+ -> ([LPat Name] -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars) -- renaming of the whole thing
+
+rnLPatsAndThen var = mapFvRnCPS (rnLPatAndThen var)
+
+
+-- the workhorse
+rnLPatAndThen :: NameMaker
+ -> LPat RdrName -- part of pattern we're currently renaming
+ -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars) -- renaming of the whole thing
+rnLPatAndThen var@(NM varf) (L loc p) cont =
+ setSrcSpan loc $
+ let reloc = L loc
+ lcont = \ unlocated -> cont (reloc unlocated)
+ in
+ case p of
+ WildPat _ -> lcont (WildPat placeHolderType)
+
+ ParPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (ParPat pat')
+ LazyPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (LazyPat pat')
+ BangPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (BangPat pat')
+
+ VarPat name ->
+ varf (reloc name) $ \ newBoundName ->
+ lcont (VarPat newBoundName)
+ -- 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 ->
+ if patsigs
+ 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
+ where
+ tvdoc = text "In a pattern type-signature"
+
+ LitPat lit@(HsString s) ->
+ do ovlStr <- doptM Opt_OverloadedStrings
+ if ovlStr
+ then rnLPatAndThen var (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont
+ else do { rnLit lit; lcont (LitPat lit) } -- Same as below
+
+ LitPat lit -> do { rnLit lit; lcont (LitPat lit) }
+
+ NPat lit mb_neg eq ->
+ do { (lit', fvs1) <- rnOverLit lit
+ ; (mb_neg', fvs2) <- case mb_neg of
+ Nothing -> return (Nothing, emptyFVs)
+ Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName
+ ; return (Just neg, fvs) }
+ ; (eq', fvs3) <- lookupSyntaxName eqName
+ ; (res, fvs4) <- lcont (NPat lit' mb_neg' eq')
+ ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+ -- Needed to find equality on pattern
+
+ NPlusKPat name lit _ _ ->
+ varf name $ \ new_name ->
+ do { (lit', fvs1) <- rnOverLit lit
+ ; (minus, fvs2) <- lookupSyntaxName minusName
+ ; (ge, fvs3) <- lookupSyntaxName geName
+ ; (res, fvs4) <- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus)
+ ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+ -- The Report says that n+k patterns must be in Integral
+
+ AsPat name pat ->
+ varf name $ \ new_name ->
+ rnLPatAndThen var pat $ \ pat' ->
+ lcont (AsPat (L (nameSrcSpan new_name) new_name) pat')
+
+ ViewPat expr pat ty ->
+ do { vp_flag <- doptM 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', fv_expr) <- rnLExpr expr
+ ; (res, fvs_res) <- rnLPatAndThen var pat $ \ pat' ->
+ lcont (ViewPat expr' pat' ty)
+ ; return (res, fvs_res `plusFV` fv_expr) }
+
+ ConPatIn con stuff ->
+ -- rnConPatAndThen takes care of reconstructing the pattern
+ rnConPatAndThen var con stuff cont
+
+ ListPat pats _ ->
+ rnLPatsAndThen var pats $ \ patslist ->
+ lcont (ListPat patslist placeHolderType)
+
+ PArrPat pats _ ->
+ do { (res, res_fvs) <- rnLPatsAndThen var pats $ \ patslist ->
+ lcont (PArrPat patslist placeHolderType)
+ ; return (res, res_fvs `plusFV` implicit_fvs) }
+ where
+ implicit_fvs = mkFVs [lengthPName, indexPName]
+
+ TuplePat pats boxed _ ->
+ do { checkTupSize (length pats)
+ ; rnLPatsAndThen var pats $ \ patslist ->
+ lcont (TuplePat patslist boxed placeHolderType) }
+
+ TypePat name ->
+ do { (name', fvs1) <- rnHsTypeFVs (text "In a type pattern") name
+ ; (res, fvs2) <- lcont (TypePat name')
+ ; return (res, fvs1 `plusFV` fvs2) }
+
+
+-- helper for renaming constructor patterns
+rnConPatAndThen :: NameMaker
+ -> Located RdrName -- the constructor
+ -> HsConPatDetails RdrName
+ -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
+ -> RnM (a, FreeVars)
+
+rnConPatAndThen var (con@(L loc _)) (PrefixCon pats) cont
+ = do { con' <- lookupLocatedOccRn con
+ ; (res, res_fvs) <- rnLPatsAndThen var pats $ \ pats' ->
+ cont (L loc $ ConPatIn con' (PrefixCon pats'))
+ ; return (res, res_fvs `addOneFV` unLoc con') }
+
+rnConPatAndThen var (con@(L loc _)) (InfixCon pat1 pat2) cont
+ = do { con' <- lookupLocatedOccRn con
+ ; (res, res_fvs) <- rnLPatAndThen var pat1 $ \ pat1' ->
+ rnLPatAndThen var pat2 $ \ pat2' ->
+ do { fixity <- lookupFixityRn (unLoc con')
+ ; pat' <- mkConOpPatRn con' fixity pat1' pat2'
+ ; cont (L loc pat') }
+ ; return (res, res_fvs `addOneFV` unLoc con') }
+
+rnConPatAndThen var (con@(L loc _)) (RecCon rpats) cont
+ = do { con' <- lookupLocatedOccRn con
+ ; (res, res_fvs) <- rnHsRecFieldsAndThen_Pattern con' var rpats $ \ rpats' ->
+ cont (L loc $ ConPatIn con' (RecCon rpats'))
+ ; return (res, res_fvs `addOneFV` unLoc con') }
+
+-- what kind of record expression we're doing
+-- the first two tell the name of the datatype constructor in question
+-- and give a way of creating a variable to fill in a ..
+data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)
+ | Pattern (Located Name) (RdrName -> a)
+ | Update
+
+choiceToMessage (Constructor _ _) = "construction"
+choiceToMessage (Pattern _ _) = "pattern"
+choiceToMessage Update = "update"
+
+doDotDot (Constructor a b) = Just (a,b)
+doDotDot (Pattern a b) = Just (a,b)
+doDotDot Update = Nothing
+
+getChoiceName (Constructor n _) = Just n
+getChoiceName (Pattern n _) = Just n
+getChoiceName (Update) = Nothing
+
+
+
+-- helper for renaming record patterns;
+-- parameterized so that it can also be used for expressions
+rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field
+ -- how to rename the fields (CPSed)
+ -> (Located field -> (Located field' -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars))
+ -- the actual fields
+ -> HsRecFields RdrName (Located field)
+ -- what to do in the scope of the field vars
+ -> (HsRecFields Name (Located field') -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+-- Haddock comments for record fields are renamed to Nothing here
+rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont =
+ let
+
+ -- helper to collect and report duplicate record fields
+ reportDuplicateFields doingstr fields =
+ let
+ -- 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
+ (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
+
+ -- helper to rename each field
+ rn_field pun_ok (HsRecField field inside pun) cont = do
+ fieldname <- lookupRecordBndr (getChoiceName choice) field
+ checkErr (not pun || pun_ok) (badPun field)
+ (res, res_fvs) <- rn_thing inside $ \ inside' ->
+ cont (HsRecField fieldname inside' pun)
+ return (res, res_fvs `addOneFV` unLoc fieldname)
+
+ -- Compute the extra fields to be filled in by the dot-dot notation
+ dot_dot_fields fs con mk_field cont = do
+ con_fields <- lookupConstructorFields (unLoc con)
+ let missing_fields = con_fields `minusList` fs
+ loc <- getSrcSpanM -- Rather approximate
+ -- it's important that we make the RdrName fields that we morally wrote
+ -- and then rename them in the usual manner
+ -- (rather than trying to make the result of renaming directly)
+ -- because, for patterns, renaming can bind vars in the continuation
+ mapFvRnCPS rn_thing
+ (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $
+ \ rhss ->
+ let new_fs = [ HsRecField (L loc f) r False
+ | (f, r) <- missing_fields `zip` rhss ]
+ in
+ cont new_fs
+
+ in do
+ -- report duplicate fields
+ let doingstr = choiceToMessage choice
+ reportDuplicateFields doingstr fields
+
+ -- rename the records as written
+ -- check whether punning (implicit x=x) is allowed
+ pun_flag <- doptM Opt_RecordPuns
+ -- rename the fields
+ mapFvRnCPS (rn_field pun_flag) fields $ \ fields1 ->
+
+ -- handle ..
+ case dd of
+ Nothing -> cont (HsRecFields fields1 dd)
+ Just n -> ASSERT( n == length fields ) do
+ dd_flag <- doptM Opt_RecordWildCards
+ 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)
+ 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")]
+
+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")]
+
+
+-- wrappers
+rnHsRecFieldsAndThen_Pattern :: Located Name
+ -> NameMaker -- new name maker
+ -> HsRecFields RdrName (LPat RdrName)
+ -> (HsRecFields Name (LPat Name) -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+rnHsRecFieldsAndThen_Pattern n var
+ = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var)
+
+
+-- wrapper to use rnLExpr in CPS style;
+-- because it does not bind any vars going forward, it does not need
+-- to be written that way
+rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> LHsExpr RdrName
+ -> (LHsExpr Name -> RnM (c, FreeVars))
+ -> RnM (c, FreeVars)
+rnLExprAndThen f e cont = do { (x, fvs1) <- f e
+ ; (res, fvs2) <- cont x
+ ; return (res, fvs1 `plusFV` fvs2) }
+
+
+-- non-CPSed because exprs don't leave anything bound
+rnHsRecFields_Con :: Located Name
+ -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> HsRecFields RdrName (LHsExpr RdrName)
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
+rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar)
+ (rnLExprAndThen rnLExpr) fields $ \ res ->
+ return (res, emptyFVs)
+
+rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
+ -> HsRecFields RdrName (LHsExpr RdrName)
+ -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
+rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update
+ (rnLExprAndThen rnLExpr) fields $ \ res ->
+ return (res, emptyFVs)
+\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 other = returnM ()
+
+rnOverLit (HsIntegral i _ _)
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
+ if inIntRange i then
+ returnM (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)
+
+rnOverLit (HsFractional i _ _)
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->
+ let
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
+ -- We have to make sure that the Ratio type is imported with
+ -- its constructor, because literals of type Ratio t are
+ -- built with that constructor.
+ -- The Rational type is needed too, but that will come in
+ -- 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)
+
+rnOverLit (HsIsString s _ _)
+ = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) ->
+ returnM (HsIsString s from_string_name placeHolderType, fvs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Errors}
+%* *
+%************************************************************************
+
+\begin{code}
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+ | tup_size <= mAX_TUPLE_SIZE
+ = returnM ()
+ | 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 ty
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it"))
+
+dupFieldErr str dup
+ = hsep [ptext SLIT("duplicate field name"),
+ quotes (ppr dup),
+ ptext SLIT("in record"), text str]
+
+bogusCharError c
+ = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
+
+badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat,
+ ptext SLIT("Use -XViewPatterns to enalbe view patterns")]
+
+\end{code}
projects / ghc-hetmet.git / commitdiff