RnBinds.lhs 33.5 KB
 simonmar committed Jun 17, 1999 1 2 3 4 5 6 7 8 9 10 11 % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnBinds]{Renaming and dependency analysis of bindings} This module does renaming and dependency analysis on value bindings in the abstract syntax. It does {\em not} do cycle-checks on class or type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code}  Ian Lynagh committed Sep 03, 2007 12 {-# OPTIONS -w #-}  Ian Lynagh committed Sep 01, 2007 13 14 15 -- 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  Ian Lynagh committed Sep 04, 2007 16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings  Ian Lynagh committed Sep 01, 2007 17 18 -- for details  Dan Licata committed Oct 10, 2007 19 20 21 22 23 module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings rnMethodBinds, renameSigs, mkSigTvFn, rnMatchGroup, rnGRHSs, makeMiniFixityEnv  simonmar committed Jun 17, 1999 24 25 26 27  ) where #include "HsVersions.h"  simonpj committed Jul 19, 2005 28 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )  simonmar committed Jun 17, 1999 29 30 31 32  import HsSyn import RdrHsSyn import RnHsSyn  simonpj committed Sep 13, 2002 33 import TcRnMonad  Dan Licata committed Oct 10, 2007 34 import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)  simonpj@microsoft.com committed Dec 13, 2007 35 36 import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker,  Dan Licata committed Oct 10, 2007 37 38 39 40 41 42 43 44 45 46  patSigErr) import RnEnv ( lookupLocatedBndrRn, lookupInstDeclBndr, newIPNameRn, lookupLocatedSigOccRn, bindPatSigTyVarsFV, bindLocalFixities, bindSigTyVarsFV, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, bindLocatedLocalsRn,  simonpj@microsoft.com committed Jan 18, 2008 47  checkDupAndShadowedRdrNames  simonmar committed Jun 17, 1999 48  )  simonmar committed Mar 18, 2005 49 import DynFlags ( DynFlag(..) )  Dan Licata committed Oct 10, 2007 50 import HscTypes (FixItem(..))  simonpj@microsoft.com committed May 02, 2007 51 import Name  simonpj committed Jul 19, 2005 52 import NameEnv  Dan Licata committed Oct 10, 2007 53 import UniqFM  simonmar committed Jun 17, 1999 54 import NameSet  simonpj committed Oct 09, 2003 55 import PrelNames ( isUnboundName )  simonpj committed Oct 03, 2000 56 import RdrName ( RdrName, rdrNameOcc )  Dan Licata committed Oct 10, 2007 57 import SrcLoc ( Located(..), unLoc, noLoc )  simonpj committed Jul 19, 2005 58 import ListSetOps ( findDupsEq )  simonpj committed Aug 10, 2005 59 60 import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp )  simonmar committed Dec 10, 2003 61 import Bag  simonmar committed Jun 17, 1999 62 import Outputable  simonpj@microsoft.com committed May 08, 2006 63 import Maybes ( orElse )  simonpj committed Aug 12, 2005 64 import Util ( filterOut )  twanvl committed Jan 17, 2008 65 import Monad ( foldM, unless )  simonmar committed Jun 17, 1999 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper -- place and can be used when complaining. The code tree received by the function @rnBinds@ contains definitions in where-clauses which are all apparently mutually recursive, but which may not really depend upon each other. For example, in the top level program \begin{verbatim} f x = y where a = x y = x \end{verbatim} the definitions of @a@ and @y@ do not depend on each other at all. Unfortunately, the typechecker cannot always check such definitions. \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive definitions. In Proceedings of the International Symposium on Programming, Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} However, the typechecker usually can check definitions in which only the strongly connected components have been collected into recursive bindings. This is precisely what the function @rnBinds@ does. ToDo: deal with case where a single monobinds binds the same variable twice. The vertag tag is a unique @Int@; the tags only need to be unique within one @MonoBinds@, so that unique-Int plumbing is done explicitly (heavy monad machinery not needed). %************************************************************************ %* * %* naming conventions * %* * %************************************************************************ \subsection[name-conventions]{Name conventions} The basic algorithm involves walking over the tree and returning a tuple containing the new tree plus its free variables. Some functions, such as those walking polymorphic bindings (HsBinds) and qualifier lists in list comprehensions (@Quals@), return the variables bound in local environments. These are then used to calculate the free variables of the expression evaluated in these environments. Conventions for variable names are as follows: \begin{itemize} \item new code is given a prime to distinguish it from the old. \item a set of variables defined in @Exp@ is written @dvExp@ \item a set of variables free in @Exp@ is written @fvExp@ \end{itemize} %************************************************************************ %* *  simonmar committed Dec 10, 2003 124 %* analysing polymorphic bindings (HsBindGroup, HsBind)  simonmar committed Jun 17, 1999 125 126 127 128 129 130 131 132 133 134 135 %* * %************************************************************************ \subsubsection[dep-HsBinds]{Polymorphic bindings} Non-recursive expressions are reconstructed without any changes at top level, although their component expressions may have to be altered. However, non-recursive expressions are currently not expected as \Haskell{} programs, and this code should not be executed. Monomorphic bindings contain information that is returned in a tuple  simonpj committed Sep 27, 2002 136 (a @FlatMonoBinds@) containing:  simonmar committed Jun 17, 1999 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174  \begin{enumerate} \item a unique @Int@ that serves as the vertex tag'' for this binding. \item the name of a function or the names in a pattern. These are a set referred to as @dvLhs@, the defined variables of the left hand side. \item the free variables of the body. These are referred to as @fvBody@. \item the definition's actual code. This is referred to as just @code@. \end{enumerate} The function @nonRecDvFv@ returns two sets of variables. The first is the set of variables defined in the set of monomorphic bindings, while the second is the set of free variables in those bindings. The set of variables defined in a non-recursive binding is just the union of all of them, as @union@ removes duplicates. However, the free variables in each successive set of cumulative bindings is the union of those in the previous set plus those of the newest binding after the defined variables of the previous set have been removed. @rnMethodBinds@ deals only with the declarations in class and instance declarations. It expects only to see @FunMonoBind@s, and it expects the global environment to contain bindings for the binders (which are all class operations). %************************************************************************ %* * \subsubsection{ Top-level bindings} %* * %************************************************************************ \begin{code}  Dan Licata committed Oct 10, 2007 175 176 177 178 179 180 181 -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings rnTopBindsLHS :: 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 -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds =  simonpj@microsoft.com committed Dec 13, 2007 182  (uncurry $rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds  Dan Licata committed Oct 10, 2007 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207  rnTopBindsRHS :: [Name] -- the names bound by these binds -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsRHS bound_names binds = do { is_boot <- tcIsHsBoot ; if is_boot then rnTopBindsBoot binds else rnValBindsRHSGen (\x -> x) -- don't trim free vars bound_names binds } -- wrapper if we don't need to do anything in between the left and right, -- or anything else in the scope of the left -- -- never used when there are fixity declarations rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = do nl <- rnTopBindsLHS emptyUFM b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names$ rnTopBindsRHS bound_names nl rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)  simonpj committed Jan 27, 2005 208 209 -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures  simonpj committed Jul 19, 2005 210 rnTopBindsBoot (ValBindsIn mbinds sigs)  simonpj committed Jan 27, 2005 211  = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)  simonpj committed Jul 19, 2005 212  ; sigs' <- renameSigs okHsBootSig sigs  simonpj committed Aug 11, 2005 213  ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }  simonpj committed Jul 19, 2005 214 215 216 217 218 219 220 221 222 223 224 \end{code} %********************************************************* %* * HsLocalBinds %* * %********************************************************* \begin{code}  Dan Licata committed Oct 10, 2007 225 226 227 228 229 rnLocalBindsAndThen :: HsLocalBinds RdrName -> (HsLocalBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are *not* already in scope -- (b) removes the binders from the free vars of the thing inside  simonpj committed Jul 19, 2005 230 231 232 233 234 235 -- The parser doesn't produce ThenBinds rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds rnLocalBindsAndThen (HsValBinds val_binds) thing_inside = rnValBindsAndThen val_binds $\ val_binds' ->  Dan Licata committed Oct 10, 2007 236  thing_inside (HsValBinds val_binds')  simonpj committed Jul 19, 2005 237   twanvl committed Jan 17, 2008 238 239 240 241 rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do (binds',fv_binds) <- rnIPBinds binds (thing, fvs_thing) <- thing_inside (HsIPBinds binds') return (thing, fvs_thing plusFV fv_binds)  simonpj committed Jul 19, 2005 242   Dan Licata committed Oct 10, 2007 243   twanvl committed Jan 17, 2008 244 245 246 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)  simonpj committed Jul 19, 2005 247   twanvl committed Jan 17, 2008 248 249 250 rnIPBind (IPBind n expr) = do name <- newIPNameRn n (expr',fvExpr) <- rnLExpr expr  simonpj committed Jul 19, 2005 251  return (IPBind name expr', fvExpr)  simonmar committed Jun 17, 1999 252 253 \end{code}  simonpj committed Sep 27, 2002 254   simonmar committed Jun 17, 1999 255 256 %************************************************************************ %* *  simonpj committed Jul 19, 2005 257  ValBinds  simonmar committed Jun 17, 1999 258 259 260 261 %* * %************************************************************************ \begin{code}  Dan Licata committed Oct 10, 2007 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 -- wrapper for local binds -- creates the documentation info and calls the helper below rnValBindsLHS :: 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 -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS fix_env binds = let (boundNames,doc) = bindersAndDoc binds in rnValBindsLHSFromDoc_Local boundNames doc fix_env binds -- a helper used for local binds that does the duplicates check, -- just so we don't forget to do it somewhere rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) -> SDoc -- doc string for dup names and shadowing -> 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 -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do -- Do error checking: we need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more.  simonpj@microsoft.com committed Jan 18, 2008 285  checkDupAndShadowedRdrNames doc boundNames  Dan Licata committed Oct 10, 2007 286 287 288 289 290 291 292 293 294 295 296  -- (Note that we don't want to do this at the top level, since -- sorting out duplicates and shadowing there happens elsewhere. -- The behavior is even different. For example, -- import A(f) -- f = ... -- should not produce a shadowing warning (but it will produce -- an ambiguity warning if you use f), but -- import A(f) -- g = let f = ... in f -- should.  simonpj@microsoft.com committed Dec 13, 2007 297  rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds  Dan Licata committed Oct 10, 2007 298 299 300  bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc) bindersAndDoc binds =  simonmar committed Jun 17, 1999 301  let  Dan Licata committed Oct 10, 2007 302 303 304  -- the unrenamed bndrs for error checking and reporting orig = collectHsValBinders binds doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig)  simonpj committed Aug 10, 2005 305  in  Dan Licata committed Oct 10, 2007 306 307 308 309 310  (orig, doc) -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level  simonpj@microsoft.com committed Dec 13, 2007 311 rnValBindsLHSFromDoc :: NameMaker  Dan Licata committed Oct 10, 2007 312 313 314 315  -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) -> SDoc -- doc string for dup names and shadowing -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName)  twanvl committed Jan 17, 2008 316 rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs) = do  Dan Licata committed Oct 10, 2007 317  -- rename the LHSes  simonpj@microsoft.com committed Dec 13, 2007 318  mbinds' <- mapBagM (rnBindLHS topP doc) mbinds  Dan Licata committed Oct 10, 2007 319 320 321 322 323 324 325 326 327 328 329 330 331  return$ ValBindsIn mbinds' sigs -- assumes the LHS vars are in scope -- general version used both from the top-level and for local things -- -- does not bind the local fixity declarations rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -- The trimming function trims the free vars we attach to a -- binding so that it stays reasonably small -> [Name] -- names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)  twanvl committed Jan 17, 2008 332 333 rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do -- rename the sigs  Dan Licata committed Oct 10, 2007 334 335 336 337 338 339 340 341 342  sigs' <- rename_sigs sigs -- rename the RHSes binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds let (anal_binds, anal_dus) = depAnalBinds binds_w_dus (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs', usesOnly (hsSigsFVs sigs') plusDU anal_dus) -- We do the check-sigs after renaming the bindings, -- so that we have convenient access to the binders check_sigs (okBindSig (duDefs anal_dus)) sigs'  twanvl committed Jan 17, 2008 343  return (valbind', valbind'_dus)  Dan Licata committed Oct 10, 2007 344 345 346 347 348 349 350 351 352 353 354 355 356  -- wrapper for local binds -- -- the *client* of this function is responsible for checking for unused binders; -- it doesn't (and can't: we don't have the thing inside the binds) happen here -- -- the client is also responsible for bringing the fixities into scope rnValBindsRHS :: [Name] -- names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnValBindsRHS bound_names binds = rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group intersectNameSet (mkNameSet bound_names) fvs) bound_names binds  simonpj committed Aug 10, 2005 357   Dan Licata committed Oct 10, 2007 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379  -- for local binds -- wrapper that does both the left- and right-hand sides -- -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs rnValBindsAndThen :: HsValBinds RdrName -> (HsValBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = let (original_bndrs, doc) = bindersAndDoc binds in do -- (A) create the local fixity environment new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] -- (B) rename the LHSes new_lhs <- rnValBindsLHSFromDoc_Local original_bndrs doc new_fixities binds let bound_names = map unLoc $collectHsValBinders new_lhs -- and bring them (and their fixities) into scope  simonpj@microsoft.com committed Dec 13, 2007 380 381  bindLocalNamesFV_WithFixities bound_names new_fixities$ warnUnusedLocalBinds bound_names $do  Dan Licata committed Oct 10, 2007 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441  -- (C) do the RHS and thing inside (binds', dus) <- rnValBindsRHS bound_names new_lhs (result, result_fvs) <- thing_inside binds' let -- the variables used in the val binds are: -- (1) the uses of the binds -- (2) the FVs of the thing-inside all_uses = (duUses dus) plusFV result_fvs -- duUses: It's important to return all the uses. Otherwise consider: -- x = 3 -- y = let p = x in 'x' -- NB: p not used -- If we don't "see" the dependency of 'y' on 'x', we may put the -- bindings in the wrong order, and the type checker will complain -- that x isn't in scope return (result, -- the bound names are pruned out of all_uses -- by the bindLocalNamesFV call above all_uses) -- Process the fixity declarations, making a FastString -> (Located Fixity) map -- (We keep the location around for reporting duplicate fixity declarations.) -- -- Checks for duplicates, but not that only locally defined things are fixed. -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM (UniqFM (Located Fixity)) -- key is the FastString of the OccName -- of the fixity declaration it came from makeMiniFixityEnv decls = foldlM add_one emptyUFM decls where add_one env (L loc (FixitySig (L name_loc name) fixity)) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) let {occ = rdrNameOcc name; curKey = occNameFS occ; fix_item = L loc fixity}; case lookupUFM env curKey of Nothing -> return$ addToUFM env curKey fix_item Just (L loc' _) -> do { setSrcSpan loc $addLocErr (L name_loc name) (dupFixityDecl loc') ; return env} } pprFixEnv :: NameEnv FixItem -> SDoc pprFixEnv env = pprWithCommas (\ (FixItem n f) -> ppr f <+> ppr n) (nameEnvElts env) dupFixityDecl loc rdr_name = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), ptext SLIT("also at ") <+> ppr loc]  simonpj committed Feb 21, 2003 442   simonpj committed Jul 19, 2005 443 ---------------------  simonpj committed Feb 21, 2003 444   Dan Licata committed Oct 10, 2007 445 446 -- renaming a single bind  simonpj@microsoft.com committed Dec 13, 2007 447 rnBindLHS :: NameMaker  Dan Licata committed Oct 10, 2007 448 449 450 451 452 453 454  -> SDoc -> LHsBind RdrName -- returns the renamed left-hand side, -- and the FreeVars *of the LHS* -- (i.e., any free variables of the pattern) -> RnM (LHsBindLR Name RdrName)  simonpj@microsoft.com committed Dec 13, 2007 455 rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat,  Dan Licata committed Oct 10, 2007 456 457 458 459 460 461  pat_rhs = grhss, bind_fvs=bind_fvs, pat_rhs_ty=pat_rhs_ty })) = setSrcSpan loc$ do -- we don't actually use the FV processing of rnPatsAndThen here  simonpj@microsoft.com committed Dec 13, 2007 462  (pat',pat'_fvs) <- rnBindPat name_maker pat  Dan Licata committed Oct 10, 2007 463 464 465 466 467 468 469 470 471 472  return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss, -- we temporarily store the pat's FVs here; -- gets updated to the FVs of the whole bind -- when doing the RHS below bind_fvs = pat'_fvs, -- these will get ignored in the next pass, -- when we rename the RHS pat_rhs_ty = pat_rhs_ty }))  simonpj@microsoft.com committed Dec 13, 2007 473 rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _),  Dan Licata committed Oct 10, 2007 474 475 476 477 478 479  fun_infix = inf, fun_matches = matches, fun_co_fn = fun_co_fn, bind_fvs = bind_fvs, fun_tick = fun_tick }))  simonpj@microsoft.com committed Dec 13, 2007 480 481 482 483 484 485 486 487 488 489 490 491 492  = setSrcSpan loc $do { (newname, _fvs) <- applyNameMaker name_maker name$ \ newname -> return (newname, emptyFVs) ; return (L loc (FunBind { fun_id = L nameLoc newname, fun_infix = inf, fun_matches = matches, -- we temporatily store the LHS's FVs (empty in this case) here -- gets updated when doing the RHS below bind_fvs = emptyFVs, -- everything else will get ignored in the next pass fun_co_fn = fun_co_fn, fun_tick = fun_tick })) }  Dan Licata committed Oct 10, 2007 493 494 495 496 497 498 499 500 501 502 503 504  -- assumes the left-hands-side vars are in scope rnBind :: (Name -> [Name]) -- Signature tyvar function -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars -> LHsBindLR Name RdrName -> RnM (LHsBind Name, [Name], Uses) rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss, -- pat fvs were stored here while processing the LHS bind_fvs=pat_fvs })) = setSrcSpan loc $do {let bndrs = collectPatBinders pat  simonpj committed Jul 19, 2005 505   Dan Licata committed Oct 10, 2007 506 507  ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss -- No scoped type variables for pattern bindings  simonpj committed Aug 10, 2005 508   Dan Licata committed Oct 10, 2007 509 510 511 512 513  ; return (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss', pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }), bndrs, pat_fvs plusFV fvs) }  simonpj committed Aug 10, 2005 514   Dan Licata committed Oct 10, 2007 515 516 517 518 519 520 521 522 523 524 525 rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches, -- no pattern FVs bind_fvs = _ })) -- invariant: no free vars here when it's a FunBind = setSrcSpan loc$ do { let plain_name = unLoc name  simonpj committed Aug 10, 2005 526   Dan Licata committed Oct 10, 2007 527 528 529  ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $-- bindSigTyVars tests for Opt_ScopedTyVars rnMatchGroup (FunRhs plain_name inf) matches  simonpj committed Aug 10, 2005 530   Dan Licata committed Oct 10, 2007 531  ; checkPrecMatch inf plain_name matches'  simonpj committed Aug 10, 2005 532   Dan Licata committed Oct 10, 2007 533 534 535 536 537 538 539 540 541  ; return (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches', bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }), [plain_name], fvs) }  simonpj committed Aug 10, 2005 542 543 544 --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses)  simonpj committed Aug 11, 2005 545 546 -- Dependency analysis; this is important so that -- unused-binding reporting is accurate  simonpj committed Aug 10, 2005 547 548 549 550 551 552 553 depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where sccs = stronglyConnComp edges keyd_nodes = bagToList binds_w_dus zip [0::Int ..]  Simon Marlow committed Mar 02, 2006 554 555  edges = [ (node, key, [key | n <- nameSetToList uses, Just key <- [lookupNameEnv key_map n] ])  simonpj committed Aug 10, 2005 556  | (node@(_,_,uses), key) <- keyd_nodes ]  simonpj committed Jul 19, 2005 557   simonpj committed Aug 10, 2005 558 559 560  key_map :: NameEnv Int -- Which binding it comes from key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes , bndr <- bndrs ]  simonpj committed Jul 19, 2005 561   simonpj committed Aug 10, 2005 562 563  get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus])  simonpj committed Jul 19, 2005 564   simonpj committed Aug 10, 2005 565 566 567 568 569  get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) get_du (CyclicSCC binds_w_dus) = (Just defs, uses) where defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]  simonpj committed Jul 19, 2005 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589  --------------------- -- Bind the top-level forall'd type variables in the sigs. -- E.g f :: a -> a -- f = rhs -- The 'a' scopes over the rhs -- -- NB: there'll usually be just one (for a function binding) -- but if there are many, one may shadow the rest; too bad! -- e.g x :: [a] -> [a] -- y :: [(a,a)] -> a -- (x,y) = e -- In e, 'a' will be in scope, and it'll be the one from 'y'! mkSigTvFn :: [LSig Name] -> (Name -> [Name]) -- Return a lookup function that maps an Id Name to the names -- of the type variables that should scope over its body.. mkSigTvFn sigs = \n -> lookupNameEnv env n orElse []  simonpj committed May 25, 2000 590  where  simonpj committed Jul 19, 2005 591 592  env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs)  simonpj committed Oct 27, 2005 593 594  | L _ (TypeSig (L _ name) (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]  simonpj committed Jul 19, 2005 595 596  -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all  simonmar committed Jun 17, 1999 597 598 599 600 \end{code} @rnMethodBinds@ is used for the method bindings of a class and an instance  simonmar committed Dec 10, 2003 601 declaration. Like @rnBinds@ but without dependency analysis.  simonmar committed Jun 17, 1999 602 603 604 605 606 607 608 609 610 611 612 613 614 615  NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. That's crucial when dealing with an instance decl: \begin{verbatim} instance Foo (T a) where op x = ... \end{verbatim} This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, and unless @op@ occurs we won't treat the type signature of @op@ in the class decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, in many ways the @op@ in an instance decl is just like an occurrence, not a binder. \begin{code}  simonpj committed Dec 06, 2001 616 rnMethodBinds :: Name -- Class name  simonpj@microsoft.com committed Jun 12, 2006 617  -> (Name -> [Name]) -- Signature tyvar function  simonpj committed Dec 06, 2001 618  -> [Name] -- Names for generic type variables  simonpj committed Sep 30, 2004 619  -> LHsBinds RdrName  simonmar committed Dec 10, 2003 620  -> RnM (LHsBinds Name, FreeVars)  simonmar committed Jun 17, 1999 621   simonpj@microsoft.com committed Jun 12, 2006 622 rnMethodBinds cls sig_fn gen_tyvars binds  simonmar committed Dec 10, 2003 623 624  = foldM do_one (emptyBag,emptyFVs) (bagToList binds) where do_one (binds,fvs) bind = do  simonpj@microsoft.com committed Jun 12, 2006 625  (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind  simonmar committed Dec 10, 2003 626  return (bind' unionBags binds, fvs_bind plusFV fvs)  simonmar committed Jun 17, 1999 627   simonpj@microsoft.com committed Jun 12, 2006 628 629 rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = MatchGroup matches _ }))  twanvl committed Jan 17, 2008 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647  = setSrcSpan loc$ do sel_name <- lookupInstDeclBndr cls name let plain_name = unLoc sel_name -- We use the selector name as the binder bindSigTyVarsFV (sig_fn plain_name) $do (new_matches, fvs) <- mapFvRn (rn_match plain_name) matches let new_group = MatchGroup new_matches placeHolderType checkPrecMatch inf plain_name new_group return (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group, bind_fvs = fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing })), fvs addOneFV plain_name) -- The 'fvs' field isn't used for method binds  simonpj committed Oct 03, 2000 648  where  simonpj committed Sep 30, 2004 649 650  -- Truly gruesome; bring into scope the correct members of the generic -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)  simonmar committed Dec 10, 2003 651  rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))  simonpj committed Sep 27, 2002 652  = extendTyVarEnvFVRn gen_tvs$  simonpj@microsoft.com committed Aug 22, 2007 653  rnMatch (FunRhs sel_name inf) match  simonpj committed Oct 03, 2000 654  where  simonmar committed Dec 10, 2003 655  tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)  simonpj committed Oct 03, 2000 656 657  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv elem tvs]  simonpj@microsoft.com committed Aug 22, 2007 658  rn_match sel_name match = rnMatch (FunRhs sel_name inf) match  simonmar committed Dec 10, 2003 659   simonmar committed Jun 17, 1999 660 661  -- Can't handle method pattern-bindings which bind multiple methods.  twanvl committed Jan 17, 2008 662 663 664 rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do addLocErr mbind methodBindErr return (emptyBag, emptyFVs)  simonmar committed Jun 17, 1999 665 666 667 \end{code}  chak@cse.unsw.edu.au. committed Sep 15, 2006 668   simonmar committed Jun 17, 1999 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 %************************************************************************ %* * \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} %* * %************************************************************************ @renameSigs@ checks for: \begin{enumerate} \item more than one sig for one thing; \item signatures given for things not bound here; \item with suitably flaggery, that all top-level things have type signatures. \end{enumerate} % At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code}  simonpj committed Jul 19, 2005 686 687 renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] -- Renames the signatures and performs error checks  twanvl committed Jan 17, 2008 688 renameSigs ok_sig sigs  simonpj committed Jul 19, 2005 689 690 691 692 693 694  = do { sigs' <- rename_sigs sigs ; check_sigs ok_sig sigs' ; return sigs' } ---------------------- rename_sigs :: [LSig RdrName] -> RnM [LSig Name]  twanvl committed Jan 17, 2008 695 rename_sigs sigs = mapM (wrapLocM renameSig) sigs  simonpj committed Jul 19, 2005 696 697 698 699  ---------------------- check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () -- Used for class and instance decls, as well as regular bindings  twanvl committed Jan 17, 2008 700 check_sigs ok_sig sigs = do  simonmar committed Jun 17, 1999 701  -- Check for (a) duplicate signatures  twanvl committed Jan 17, 2008 702 703 704 705  -- (b) signatures for things not in this group = do traceRn (text "SIGS" <+> ppr sigs) mapM_ unknownSigErr (filter (not . ok_sig) sigs') mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs')  simonpj committed Sep 27, 2002 706  where  simonpj committed Jul 25, 2005 707  -- Don't complain about an unbound name again  simonpj committed Aug 12, 2005 708 709 710 711  sigs' = filterOut bad_name sigs bad_name sig = case sigName sig of Just n -> isUnboundName n other -> False  simonpj committed Jul 25, 2005 712   simonpj committed Jul 19, 2005 713 -- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory  simonmar committed Jun 17, 1999 714 715 716 717 718 719 720 721 -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} -- Baz.op = ... -- We'll just rename the INLINE prag to refer to whatever other 'op' -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this.  simonpj committed Sep 13, 2002 722 renameSig :: Sig RdrName -> RnM (Sig Name)  simonpj committed Oct 09, 2003 723 -- FixitSig is renamed elsewhere.  twanvl committed Jan 17, 2008 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 renameSig (TypeSig v ty) = do new_v <- lookupLocatedSigOccRn v new_ty <- rnHsSigType (quotes (ppr v)) ty return (TypeSig new_v new_ty) renameSig (SpecInstSig ty) = do new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty return (SpecInstSig new_ty) renameSig (SpecSig v ty inl) = do new_v <- lookupLocatedSigOccRn v new_ty <- rnHsSigType (quotes (ppr v)) ty return (SpecSig new_v new_ty inl) renameSig (InlineSig v s) = do new_v <- lookupLocatedSigOccRn v return (InlineSig new_v s) renameSig (FixSig (FixitySig v f)) = do new_v <- lookupLocatedSigOccRn v return (FixSig (FixitySig new_v f))  simonmar committed Jun 17, 1999 745 746 747 \end{code}  simonpj committed Jul 19, 2005 748 749 750 751 752 753 754 755 ************************************************************************ * * \subsection{Match} * * ************************************************************************ \begin{code} rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)  twanvl committed Jan 17, 2008 756 757 758 rnMatchGroup ctxt (MatchGroup ms _) = do (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms return (MatchGroup new_ms placeHolderType, ms_fvs)  simonpj committed Jul 19, 2005 759 760 761 762 763 764 765  rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) = -- Deal with the rhs type signature  twanvl committed Jan 17, 2008 766 767 768 769 770 771 772 773 774 775 776  bindPatSigTyVarsFV rhs_sig_tys $do opt_PatternSignatures <- doptM Opt_PatternSignatures (maybe_rhs_sig', ty_fvs) <- case maybe_rhs_sig of Nothing -> return (Nothing, emptyFVs) Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty return (Just ty', ty_fvs) | otherwise -> do addLocErr ty patSigErr return (Nothing, emptyFVs) -- Now the main event  Dan Licata committed Oct 10, 2007 777  -- note that there are no local ficity decls for matches  twanvl committed Jan 17, 2008 778 779  rnPatsAndThen_LocalRightwards ctxt pats$ \ pats' -> do (grhss', grhss_fvs) <- rnGRHSs ctxt grhss  simonpj committed Jul 19, 2005 780   twanvl committed Jan 17, 2008 781  return (Match pats' maybe_rhs_sig' grhss', grhss_fvs plusFV ty_fvs)  simonpj committed Jul 19, 2005 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800  -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where rhs_sig_tys = case maybe_rhs_sig of Nothing -> [] Just ty -> [ty] doc_sig = text "In a result type-signature" \end{code} %************************************************************************ %* * \subsubsection{Guarded right-hand sides (GRHSs)} %* * %************************************************************************ \begin{code} rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) rnGRHSs ctxt (GRHSs grhss binds)  twanvl committed Jan 17, 2008 801 802 803  = rnLocalBindsAndThen binds $\ binds' -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss return (GRHSs grhss' binds', fvGRHSs)  simonpj committed Jul 19, 2005 804 805 806 807 808  rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) rnGRHS' ctxt (GRHS guards rhs)  Ian Lynagh committed Jul 08, 2007 809  = do { pattern_guards_allowed <- doptM Opt_PatternGuards  simonpj committed Jul 19, 2005 810 811  ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards$ rnLExpr rhs  simonpj@microsoft.com committed Feb 06, 2006 812   twanvl committed Jan 17, 2008 813  ; unless (pattern_guards_allowed || is_standard_guard guards')  simonpj@microsoft.com committed Feb 06, 2006 814 815  (addWarn (nonStdGuardErr guards'))  simonpj committed Jul 19, 2005 816 817 818 819 820 821 822 823 824 825  ; return (GRHS guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension is_standard_guard [] = True is_standard_guard [L _ (ExprStmt _ _ _)] = True is_standard_guard other = False \end{code}  simonmar committed Jun 17, 1999 826 827 828 829 830 831 832 %************************************************************************ %* * \subsection{Error messages} %* * %************************************************************************ \begin{code}  simonpj committed Jul 19, 2005 833 dupSigDeclErr sigs@(L loc sig : _)  simonmar committed Dec 10, 2003 834 835  = addErrAt loc $vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,  simonpj committed Jul 19, 2005 836  nest 2 (vcat (map ppr_sig sigs))]  simonmar committed Jun 17, 1999 837  where  simonmar committed Dec 10, 2003 838 839  what_it_is = hsSigDoc sig ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig  simonmar committed Jun 17, 1999 840   simonmar committed Dec 10, 2003 841 unknownSigErr (L loc sig)  simonpj@microsoft.com committed May 02, 2007 842 843 844 845  = do { mod <- getModule ; addErrAt loc$ vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig], extra_stuff mod sig] }  simonmar committed Jun 17, 1999 846  where  simonmar committed Dec 10, 2003 847  what_it_is = hsSigDoc sig  simonpj@microsoft.com committed May 02, 2007 848 849 850 851 852 853 854 855  extra_stuff mod (TypeSig (L _ n) _) | nameIsLocalOrFrom mod n = ptext SLIT("The type signature must be given where") <+> quotes (ppr n) <+> ptext SLIT("is declared") | otherwise = ptext SLIT("You cannot give a type signature for an imported value") extra_stuff mod other = empty  simonmar committed Jun 17, 1999 856 857  methodBindErr mbind  simonpj committed Oct 11, 2004 858  = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))  simonpj committed Jan 27, 2005 859 860 861 862 863  2 (ppr mbind) bindsInHsBootFile mbinds = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) 2 (ppr mbinds)  simonpj committed Jul 19, 2005 864   simonpj@microsoft.com committed Feb 06, 2006 865 nonStdGuardErr guards  Ian Lynagh committed Jul 08, 2007 866  = hang (ptext SLIT("accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))  simonpj@microsoft.com committed Feb 06, 2006 867  4 (interpp'SP guards)  simonmar committed Jun 17, 1999 868 \end{code}