2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
9 rnHsType, rnLHsType, rnLHsTypes, rnContext,
10 rnHsSigType, rnHsTypeFVs,
12 -- Precence related stuff
13 mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
14 checkPrecMatch, checkSectionPrec
19 import RdrHsSyn ( extractHsRhoRdrTyVars )
20 import RnHsSyn ( extractHsTyNames )
21 import RnHsDoc ( rnLHsDoc )
26 import TypeRep ( funTyConName )
31 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
32 Fixity(..), FixityDirection(..) )
35 import Control.Monad ( unless )
37 #include "HsVersions.h"
40 These type renamers are in a separate module, rather than in (say) RnSource,
41 to break several loop.
43 %*********************************************************
45 \subsection{Renaming types}
47 %*********************************************************
50 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
51 rnHsTypeFVs doc_str ty = do
52 ty' <- rnLHsType doc_str ty
53 return (ty', extractHsTyNames ty')
55 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
56 -- rnHsSigType is used for source-language type signatures,
57 -- which use *implicit* universal quantification.
58 rnHsSigType doc_str ty
59 = rnLHsType (text "In the type signature for" <+> doc_str) ty
62 rnHsType is here because we call it from loadInstDecl, and I didn't
63 want a gratuitous knot.
66 rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
67 rnLHsType doc = wrapLocM (rnHsType doc)
69 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
71 rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
72 -- Implicit quantifiction in source code (no kinds on tyvars)
73 -- Given the signature C => T we universally quantify
74 -- over FV(T) \ {in-scope-tyvars}
75 name_env <- getLocalRdrEnv
77 mentioned = extractHsRhoRdrTyVars ctxt ty
79 -- Don't quantify over type variables that are in scope;
80 -- when GlasgowExts is off, there usually won't be any, except for
82 -- class C a where { op :: a -> a }
83 forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
84 tyvar_bndrs = userHsTyVarBndrs forall_tyvars
86 rnForAll doc Implicit tyvar_bndrs ctxt ty
88 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
89 -- Explicit quantification.
90 -- Check that the forall'd tyvars are actually
91 -- mentioned in the type, and produce a warning if not
93 mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau)
94 forall_tyvar_names = hsLTyVarLocNames forall_tyvars
96 -- Explicitly quantified but not mentioned in ctxt or tau
97 warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
99 mapM_ (forAllWarn doc tau) warn_guys
100 rnForAll doc Explicit forall_tyvars ctxt tau
102 rnHsType _ (HsTyVar tyvar) = do
103 tyvar' <- lookupOccRn tyvar
104 return (HsTyVar tyvar')
106 -- If we see (forall a . ty), without foralls on, the forall will give
107 -- a sensible error message, but we don't want to complain about the dot too
108 -- Hence the jiggery pokery with ty1
109 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
111 do { ops_ok <- doptM Opt_TypeOperators
114 else do { addErr (opTyErr op ty)
115 ; return (mkUnboundName op) } -- Avoid double complaint
116 ; let l_op' = L loc op'
117 ; fix <- lookupTyFixityRn l_op'
118 ; ty1' <- rnLHsType doc ty1
119 ; ty2' <- rnLHsType doc ty2
120 ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
122 rnHsType doc (HsParTy ty) = do
123 ty' <- rnLHsType doc ty
126 rnHsType doc (HsBangTy b ty) = do
127 ty' <- rnLHsType doc ty
128 return (HsBangTy b ty')
130 rnHsType _ (HsNumTy i)
131 | i == 1 = return (HsNumTy i)
132 | otherwise = addErr err_msg >> return (HsNumTy i)
134 err_msg = ptext (sLit "Only unit numeric type pattern is valid")
137 rnHsType doc (HsFunTy ty1 ty2) = do
138 ty1' <- rnLHsType doc ty1
139 -- Might find a for-all as the arg of a function type
140 ty2' <- rnLHsType doc ty2
141 -- Or as the result. This happens when reading Prelude.hi
142 -- when we find return :: forall m. Monad m -> forall a. a -> m a
144 -- Check for fixity rearrangements
145 mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
147 rnHsType doc (HsListTy ty) = do
148 ty' <- rnLHsType doc ty
149 return (HsListTy ty')
151 rnHsType doc (HsKindSig ty k) = do
152 ty' <- rnLHsType doc ty
153 return (HsKindSig ty' k)
155 rnHsType doc (HsPArrTy ty) = do
156 ty' <- rnLHsType doc ty
157 return (HsPArrTy ty')
159 -- Unboxed tuples are allowed to have poly-typed arguments. These
160 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
161 rnHsType doc (HsTupleTy tup_con tys) = do
162 tys' <- mapM (rnLHsType doc) tys
163 return (HsTupleTy tup_con tys')
165 rnHsType doc (HsAppTy ty1 ty2) = do
166 ty1' <- rnLHsType doc ty1
167 ty2' <- rnLHsType doc ty2
168 return (HsAppTy ty1' ty2')
170 rnHsType doc (HsPredTy pred) = do
171 pred' <- rnPred doc pred
172 return (HsPredTy pred')
174 rnHsType _ (HsSpliceTy _) =
175 failWith (ptext (sLit "Type splices are not yet implemented"))
177 rnHsType doc (HsDocTy ty haddock_doc) = do
178 ty' <- rnLHsType doc ty
179 haddock_doc' <- rnLHsDoc haddock_doc
180 return (HsDocTy ty' haddock_doc')
182 rnLHsTypes :: SDoc -> [LHsType RdrName]
183 -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
184 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
189 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
190 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
192 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
193 -- One reason for this case is that a type like Int#
194 -- starts off as (HsForAllTy Nothing [] Int), in case
195 -- there is some quantification. Now that we have quantified
196 -- and discovered there are no type variables, it's nicer to turn
197 -- it into plain Int. If it were Int# instead of Int, we'd actually
198 -- get an error, because the body of a genuine for-all is
201 rnForAll doc exp forall_tyvars ctxt ty
202 = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
203 new_ctxt <- rnContext doc ctxt
204 new_ty <- rnLHsType doc ty
205 return (HsForAllTy exp new_tyvars new_ctxt new_ty)
206 -- Retain the same implicit/explicit flag as before
207 -- so that we can later print it correctly
210 %*********************************************************
212 \subsection{Contexts and predicates}
214 %*********************************************************
217 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
218 rnContext doc = wrapLocM (rnContext' doc)
220 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
221 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
223 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
224 rnLPred doc = wrapLocM (rnPred doc)
226 rnPred :: SDoc -> HsPred RdrName
227 -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
228 rnPred doc (HsClassP clas tys)
229 = do { clas_name <- lookupOccRn clas
230 ; tys' <- rnLHsTypes doc tys
231 ; return (HsClassP clas_name tys')
233 rnPred doc (HsEqualP ty1 ty2)
234 = do { ty1' <- rnLHsType doc ty1
235 ; ty2' <- rnLHsType doc ty2
236 ; return (HsEqualP ty1' ty2')
238 rnPred doc (HsIParam n ty)
239 = do { name <- newIPNameRn n
240 ; ty' <- rnLHsType doc ty
241 ; return (HsIParam name ty')
246 %************************************************************************
248 Fixities and precedence parsing
250 %************************************************************************
252 @mkOpAppRn@ deals with operator fixities. The argument expressions
253 are assumed to be already correctly arranged. It needs the fixities
254 recorded in the OpApp nodes, because fixity info applies to the things
255 the programmer actually wrote, so you can't find it out from the Name.
257 Furthermore, the second argument is guaranteed not to be another
258 operator application. Why? Because the parser parses all
259 operator appications left-associatively, EXCEPT negation, which
260 we need to handle specially.
261 Infix types are read in a *right-associative* way, so that
266 mkHsOpTyRn rearranges where necessary. The two arguments
267 have already been renamed and rearranged. It's made rather tiresome
268 by the presence of ->, which is a separate syntactic construct.
272 -- Building (ty1 `op1` (ty21 `op2` ty22))
273 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
274 -> Name -> Fixity -> LHsType Name -> LHsType Name
277 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
278 = do { fix2 <- lookupTyFixityRn op2
279 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
280 (\t1 t2 -> HsOpTy t1 op2 t2)
281 (unLoc op2) fix2 ty21 ty22 loc2 }
283 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
284 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
285 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
287 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
288 = return (mk1 ty1 ty2)
291 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
292 -> Name -> Fixity -> LHsType Name
293 -> (LHsType Name -> LHsType Name -> HsType Name)
294 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
296 mk_hs_op_ty mk1 op1 fix1 ty1
297 mk2 op2 fix2 ty21 ty22 loc2
298 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
299 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
300 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
301 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
302 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
303 ; return (mk2 (noLoc new_ty) ty22) }
305 (nofix_error, associate_right) = compareFixity fix1 fix2
308 ---------------------------
309 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
310 -> LHsExpr Name -> Fixity -- Operator and fixity
311 -> LHsExpr Name -- Right operand (not an OpApp, but might
315 -- (e11 `op1` e12) `op2` e2
316 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
318 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
319 return (OpApp e1 op2 fix2 e2)
321 | associate_right = do
322 new_e <- mkOpAppRn e12 op2 fix2 e2
323 return (OpApp e11 op1 fix1 (L loc' new_e))
325 loc'= combineLocs e12 e2
326 (nofix_error, associate_right) = compareFixity fix1 fix2
328 ---------------------------
329 -- (- neg_arg) `op` e2
330 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
332 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
333 return (OpApp e1 op2 fix2 e2)
336 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
337 return (NegApp (L loc' new_e) neg_name)
339 loc' = combineLocs neg_arg e2
340 (nofix_error, associate_right) = compareFixity negateFixity fix2
342 ---------------------------
344 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
345 | not associate_right -- We *want* right association
346 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
347 return (OpApp e1 op1 fix1 e2)
349 (_, associate_right) = compareFixity fix1 negateFixity
351 ---------------------------
353 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
354 = ASSERT2( right_op_ok fix (unLoc e2),
355 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
357 return (OpApp e1 op fix e2)
359 ----------------------------
360 get_op :: LHsExpr Name -> Name
361 get_op (L _ (HsVar n)) = n
362 get_op other = pprPanic "get_op" (ppr other)
364 -- Parser left-associates everything, but
365 -- derived instances may have correctly-associated things to
366 -- in the right operarand. So we just check that the right operand is OK
367 right_op_ok :: Fixity -> HsExpr Name -> Bool
368 right_op_ok fix1 (OpApp _ _ fix2 _)
369 = not error_please && associate_right
371 (error_please, associate_right) = compareFixity fix1 fix2
375 -- Parser initially makes negation bind more tightly than any other operator
376 -- And "deriving" code should respect this (use HsPar if not)
377 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
378 mkNegAppRn neg_arg neg_name
379 = ASSERT( not_op_app (unLoc neg_arg) )
380 return (NegApp neg_arg neg_name)
382 not_op_app :: HsExpr id -> Bool
383 not_op_app (OpApp _ _ _ _) = False
386 ---------------------------
387 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
388 -> LHsExpr Name -> Fixity -- Operator and fixity
389 -> LHsCmdTop Name -- Right operand (not an infix)
392 -- (e11 `op1` e12) `op2` e2
393 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
396 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
397 return (HsArrForm op2 (Just fix2) [a1, a2])
400 = do new_c <- mkOpFormRn a12 op2 fix2 a2
401 return (HsArrForm op1 (Just fix1)
402 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
403 -- TODO: locs are wrong
405 (nofix_error, associate_right) = compareFixity fix1 fix2
408 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
409 = return (HsArrForm op (Just fix) [arg1, arg2])
412 --------------------------------------
413 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
416 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
417 = do { fix1 <- lookupFixityRn (unLoc op1)
418 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
420 ; if nofix_error then do
421 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
422 ; return (ConPatIn op2 (InfixCon p1 p2)) }
424 else if associate_right then do
425 { new_p <- mkConOpPatRn op2 fix2 p12 p2
426 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
427 else return (ConPatIn op2 (InfixCon p1 p2)) }
429 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
430 = ASSERT( not_op_pat (unLoc p2) )
431 return (ConPatIn op (InfixCon p1 p2))
433 not_op_pat :: Pat Name -> Bool
434 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
437 --------------------------------------
438 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
439 -- True indicates an infix lhs
440 -- See comments with rnExpr (OpApp ...) about "deriving"
442 checkPrecMatch False _ _
444 checkPrecMatch True op (MatchGroup ms _)
447 check (L _ (Match (p1:p2:_) _ _))
448 = do checkPrec op (unLoc p1) False
449 checkPrec op (unLoc p2) True
452 -- This can happen. Consider
455 -- The infix flag comes from the first binding of the group
456 -- but the second eqn has no args (an error, but not discovered
457 -- until the type checker). So we don't want to crash on the
460 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
461 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
462 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
463 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
465 inf_ok = op1_prec > op_prec ||
466 (op1_prec == op_prec &&
467 (op1_dir == InfixR && op_dir == InfixR && right ||
468 op1_dir == InfixL && op_dir == InfixL && not right))
471 info1 = (unLoc op1, op1_fix)
472 (infol, infor) = if right then (info, info1) else (info1, info)
473 unless inf_ok (precParseErr infol infor)
478 -- Check precedence of (arg op) or (op arg) respectively
479 -- If arg is itself an operator application, then either
480 -- (a) its precedence must be higher than that of op
481 -- (b) its precedency & associativity must be the same as that of op
482 checkSectionPrec :: FixityDirection -> HsExpr RdrName
483 -> LHsExpr Name -> LHsExpr Name -> RnM ()
484 checkSectionPrec direction section op arg
486 OpApp _ op fix _ -> go_for_it (get_op op) fix
487 NegApp _ _ -> go_for_it negateName negateFixity
491 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
492 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
493 unless (op_prec < arg_prec
494 || (op_prec == arg_prec && direction == assoc))
495 (sectionPrecErr (op_name, op_fix)
496 (arg_op, arg_fix) section)
499 Precedence-related error messages
502 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
503 precParseErr op1@(n1,_) op2@(n2,_)
504 | isUnboundName n1 || isUnboundName n2
505 = return () -- Avoid error cascade
507 = addErr $ hang (ptext (sLit "Precedence parsing error"))
508 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
510 ptext (sLit "in the same infix expression")])
512 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
513 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
514 | isUnboundName n1 || isUnboundName n2
515 = return () -- Avoid error cascade
517 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
518 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
519 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
520 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
522 ppr_opfix :: (Name, Fixity) -> SDoc
523 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
525 pp_op | op == negateName = ptext (sLit "prefix `-'")
526 | otherwise = quotes (ppr op)
529 %*********************************************************
533 %*********************************************************
536 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
537 -> TcRnIf TcGblEnv TcLclEnv ()
538 forAllWarn doc ty (L loc tyvar)
539 = ifOptM Opt_WarnUnusedMatches $
540 addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
541 nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
545 opTyErr :: RdrName -> HsType RdrName -> SDoc
546 opTyErr op ty@(HsOpTy ty1 _ _)
547 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
550 extra | op == dot_tv_RDR && forall_head ty1
553 = ptext (sLit "Use -XTypeOperators to allow operators in types")
555 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
556 forall_head (L _ (HsAppTy ty _)) = forall_head ty
557 forall_head _other = False
558 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)