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 ( funTyCon )
31 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
32 Fixity(..), FixityDirection(..) )
36 #include "HsVersions.h"
39 These type renamers are in a separate module, rather than in (say) RnSource,
40 to break several loop.
42 %*********************************************************
44 \subsection{Renaming types}
46 %*********************************************************
49 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
50 rnHsTypeFVs doc_str ty = do
51 ty' <- rnLHsType doc_str ty
52 return (ty', extractHsTyNames ty')
54 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
55 -- rnHsSigType is used for source-language type signatures,
56 -- which use *implicit* universal quantification.
57 rnHsSigType doc_str ty
58 = rnLHsType (text "In the type signature for" <+> doc_str) ty
61 rnHsType is here because we call it from loadInstDecl, and I didn't
62 want a gratuitous knot.
65 rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
66 rnLHsType doc = wrapLocM (rnHsType doc)
68 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
70 rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
71 -- Implicit quantifiction in source code (no kinds on tyvars)
72 -- Given the signature C => T we universally quantify
73 -- over FV(T) \ {in-scope-tyvars}
74 name_env <- getLocalRdrEnv
76 mentioned = extractHsRhoRdrTyVars ctxt ty
78 -- Don't quantify over type variables that are in scope;
79 -- when GlasgowExts is off, there usually won't be any, except for
81 -- class C a where { op :: a -> a }
82 forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
83 tyvar_bndrs = userHsTyVarBndrs forall_tyvars
85 rnForAll doc Implicit tyvar_bndrs ctxt ty
87 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
88 -- Explicit quantification.
89 -- Check that the forall'd tyvars are actually
90 -- mentioned in the type, and produce a warning if not
92 mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau)
93 forall_tyvar_names = hsLTyVarLocNames forall_tyvars
95 -- Explicitly quantified but not mentioned in ctxt or tau
96 warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
98 mapM_ (forAllWarn doc tau) warn_guys
99 rnForAll doc Explicit forall_tyvars ctxt tau
101 rnHsType _ (HsTyVar tyvar) = do
102 tyvar' <- lookupOccRn tyvar
103 return (HsTyVar tyvar')
105 -- If we see (forall a . ty), without foralls on, the forall will give
106 -- a sensible error message, but we don't want to complain about the dot too
107 -- Hence the jiggery pokery with ty1
108 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
110 do { ops_ok <- doptM Opt_TypeOperators
113 else do { addErr (opTyErr op ty)
114 ; return (mkUnboundName op) } -- Avoid double complaint
115 ; let l_op' = L loc op'
116 ; fix <- lookupTyFixityRn l_op'
117 ; ty1' <- rnLHsType doc ty1
118 ; ty2' <- rnLHsType doc ty2
119 ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' }
121 rnHsType doc (HsParTy ty) = do
122 ty' <- rnLHsType doc ty
125 rnHsType doc (HsBangTy b ty) = do
126 ty' <- rnLHsType doc ty
127 return (HsBangTy b ty')
129 rnHsType _ (HsNumTy i)
130 | i == 1 = return (HsNumTy i)
131 | otherwise = addErr err_msg >> return (HsNumTy i)
133 err_msg = ptext (sLit "Only unit numeric type pattern is valid")
136 rnHsType doc (HsFunTy ty1 ty2) = do
137 ty1' <- rnLHsType doc ty1
138 -- Might find a for-all as the arg of a function type
139 ty2' <- rnLHsType doc ty2
140 -- Or as the result. This happens when reading Prelude.hi
141 -- when we find return :: forall m. Monad m -> forall a. a -> m a
143 -- Check for fixity rearrangements
144 mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
146 rnHsType doc (HsListTy ty) = do
147 ty' <- rnLHsType doc ty
148 return (HsListTy ty')
150 rnHsType doc (HsKindSig ty k) = do
151 ty' <- rnLHsType doc ty
152 return (HsKindSig ty' k)
154 rnHsType doc (HsPArrTy ty) = do
155 ty' <- rnLHsType doc ty
156 return (HsPArrTy ty')
158 -- Unboxed tuples are allowed to have poly-typed arguments. These
159 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
160 rnHsType doc (HsTupleTy tup_con tys) = do
161 tys' <- mapM (rnLHsType doc) tys
162 return (HsTupleTy tup_con tys')
164 rnHsType doc (HsAppTy ty1 ty2) = do
165 ty1' <- rnLHsType doc ty1
166 ty2' <- rnLHsType doc ty2
167 return (HsAppTy ty1' ty2')
169 rnHsType doc (HsPredTy pred) = do
170 pred' <- rnPred doc pred
171 return (HsPredTy pred')
173 rnHsType _ (HsSpliceTy _) =
174 failWith (ptext (sLit "Type splices are not yet implemented"))
176 rnHsType doc (HsDocTy ty haddock_doc) = do
177 ty' <- rnLHsType doc ty
178 haddock_doc' <- rnLHsDoc haddock_doc
179 return (HsDocTy ty' haddock_doc')
181 rnLHsTypes :: SDoc -> [LHsType RdrName]
182 -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
183 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
188 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
189 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
191 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
192 -- One reason for this case is that a type like Int#
193 -- starts off as (HsForAllTy Nothing [] Int), in case
194 -- there is some quantification. Now that we have quantified
195 -- and discovered there are no type variables, it's nicer to turn
196 -- it into plain Int. If it were Int# instead of Int, we'd actually
197 -- get an error, because the body of a genuine for-all is
200 rnForAll doc exp forall_tyvars ctxt ty
201 = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
202 new_ctxt <- rnContext doc ctxt
203 new_ty <- rnLHsType doc ty
204 return (HsForAllTy exp new_tyvars new_ctxt new_ty)
205 -- Retain the same implicit/explicit flag as before
206 -- so that we can later print it correctly
209 %*********************************************************
211 \subsection{Contexts and predicates}
213 %*********************************************************
216 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
217 rnContext doc = wrapLocM (rnContext' doc)
219 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
220 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
222 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
223 rnLPred doc = wrapLocM (rnPred doc)
225 rnPred :: SDoc -> HsPred RdrName
226 -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
227 rnPred doc (HsClassP clas tys)
228 = do { clas_name <- lookupOccRn clas
229 ; tys' <- rnLHsTypes doc tys
230 ; return (HsClassP clas_name tys')
232 rnPred doc (HsEqualP ty1 ty2)
233 = do { ty1' <- rnLHsType doc ty1
234 ; ty2' <- rnLHsType doc ty2
235 ; return (HsEqualP ty1' ty2')
237 rnPred doc (HsIParam n ty)
238 = do { name <- newIPNameRn n
239 ; ty' <- rnLHsType doc ty
240 ; return (HsIParam name ty')
245 %************************************************************************
247 Fixities and precedence parsing
249 %************************************************************************
251 @mkOpAppRn@ deals with operator fixities. The argument expressions
252 are assumed to be already correctly arranged. It needs the fixities
253 recorded in the OpApp nodes, because fixity info applies to the things
254 the programmer actually wrote, so you can't find it out from the Name.
256 Furthermore, the second argument is guaranteed not to be another
257 operator application. Why? Because the parser parses all
258 operator appications left-associatively, EXCEPT negation, which
259 we need to handle specially.
260 Infix types are read in a *right-associative* way, so that
265 mkHsOpTyRn rearranges where necessary. The two arguments
266 have already been renamed and rearranged. It's made rather tiresome
267 by the presence of ->, which is a separate syntactic construct.
271 -- Building (ty1 `op1` (ty21 `op2` ty22))
272 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
273 -> SDoc -> Fixity -> LHsType Name -> LHsType Name
276 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
277 = do { fix2 <- lookupTyFixityRn op2
278 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
279 (\t1 t2 -> HsOpTy t1 op2 t2)
280 (ppr op2) fix2 ty21 ty22 loc2 }
282 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
283 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
284 HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
286 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
287 = return (mk1 ty1 ty2)
290 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
291 -> SDoc -> Fixity -> LHsType Name
292 -> (LHsType Name -> LHsType Name -> HsType Name)
293 -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
295 mk_hs_op_ty mk1 pp_op1 fix1 ty1
296 mk2 pp_op2 fix2 ty21 ty22 loc2
297 | nofix_error = do { addErr (precParseErr (quotes pp_op1,fix1)
298 (quotes pp_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 pp_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 addErr (precParseErr (ppr_op op1,fix1) (ppr_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 addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))
333 return (OpApp e1 op2 fix2 e2)
335 | associate_right = do
336 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= do -- We *want* right association
346 addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, 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 -- Parser left-associates everything, but
360 -- derived instances may have correctly-associated things to
361 -- in the right operarand. So we just check that the right operand is OK
362 right_op_ok :: Fixity -> HsExpr Name -> Bool
363 right_op_ok fix1 (OpApp _ _ fix2 _)
364 = not error_please && associate_right
366 (error_please, associate_right) = compareFixity fix1 fix2
370 -- Parser initially makes negation bind more tightly than any other operator
371 -- And "deriving" code should respect this (use HsPar if not)
372 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
373 mkNegAppRn neg_arg neg_name
374 = ASSERT( not_op_app (unLoc neg_arg) )
375 return (NegApp neg_arg neg_name)
377 not_op_app :: HsExpr id -> Bool
378 not_op_app (OpApp _ _ _ _) = False
381 ---------------------------
382 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
383 -> LHsExpr Name -> Fixity -- Operator and fixity
384 -> LHsCmdTop Name -- Right operand (not an infix)
387 -- (e11 `op1` e12) `op2` e2
388 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
391 addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
392 return (HsArrForm op2 (Just fix2) [a1, a2])
394 | associate_right = do
395 new_c <- mkOpFormRn a12 op2 fix2 a2
396 return (HsArrForm op1 (Just fix1)
397 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
398 -- TODO: locs are wrong
400 (nofix_error, associate_right) = compareFixity fix1 fix2
403 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
404 = return (HsArrForm op (Just fix) [arg1, arg2])
407 --------------------------------------
408 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
411 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
412 = do { fix1 <- lookupFixityRn (unLoc op1)
413 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
415 ; if nofix_error then do
416 { addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
417 ; return (ConPatIn op2 (InfixCon p1 p2)) }
419 else if associate_right then do
420 { new_p <- mkConOpPatRn op2 fix2 p12 p2
421 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
422 else return (ConPatIn op2 (InfixCon p1 p2)) }
424 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
425 = ASSERT( not_op_pat (unLoc p2) )
426 return (ConPatIn op (InfixCon p1 p2))
428 not_op_pat :: Pat Name -> Bool
429 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
432 --------------------------------------
433 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
434 -- True indicates an infix lhs
435 -- See comments with rnExpr (OpApp ...) about "deriving"
437 checkPrecMatch False _ _
439 checkPrecMatch True op (MatchGroup ms _)
442 check (L _ (Match (p1:p2:_) _ _))
443 = do checkPrec op (unLoc p1) False
444 checkPrec op (unLoc p2) True
447 -- This can happen. Consider
450 -- The infix flag comes from the first binding of the group
451 -- but the second eqn has no args (an error, but not discovered
452 -- until the type checker). So we don't want to crash on the
455 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
456 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
457 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
458 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
460 inf_ok = op1_prec > op_prec ||
461 (op1_prec == op_prec &&
462 (op1_dir == InfixR && op_dir == InfixR && right ||
463 op1_dir == InfixL && op_dir == InfixL && not right))
465 info = (ppr_op op, op_fix)
466 info1 = (ppr_op op1, op1_fix)
467 (infol, infor) = if right then (info, info1) else (info1, info)
469 checkErr inf_ok (precParseErr infol infor)
474 -- Check precedence of (arg op) or (op arg) respectively
475 -- If arg is itself an operator application, then either
476 -- (a) its precedence must be higher than that of op
477 -- (b) its precedency & associativity must be the same as that of op
478 checkSectionPrec :: FixityDirection -> HsExpr RdrName
479 -> LHsExpr Name -> LHsExpr Name -> RnM ()
480 checkSectionPrec direction section op arg
482 OpApp _ op fix _ -> go_for_it (ppr_op op) fix
483 NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
486 L _ (HsVar op_name) = op
487 go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = do
488 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
489 checkErr (op_prec < arg_prec
490 || op_prec == arg_prec && direction == assoc)
491 (sectionPrecErr (ppr_op op_name, op_fix)
492 (pp_arg_op, arg_fix) section)
495 Precedence-related error messages
498 precParseErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> SDoc
500 = hang (ptext (sLit "precedence parsing error"))
501 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
503 ptext (sLit "in the same infix expression")])
505 sectionPrecErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> HsExpr RdrName -> SDoc
506 sectionPrecErr op arg_op section
507 = vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
508 nest 4 (ptext (sLit "must have lower precedence than the operand") <+> ppr_opfix arg_op),
509 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
511 pp_prefix_minus :: SDoc
512 pp_prefix_minus = ptext (sLit "prefix `-'")
513 ppr_op :: Outputable a => a -> SDoc
514 ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
515 ppr_opfix :: (SDoc, Fixity) -> SDoc
516 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
519 %*********************************************************
523 %*********************************************************
526 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
527 -> TcRnIf TcGblEnv TcLclEnv ()
528 forAllWarn doc ty (L loc tyvar)
529 = ifOptM Opt_WarnUnusedMatches $
530 addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
531 nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
535 opTyErr :: RdrName -> HsType RdrName -> SDoc
536 opTyErr op ty@(HsOpTy ty1 _ _)
537 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
540 extra | op == dot_tv_RDR && forall_head ty1
543 = ptext (sLit "Use -XTypeOperators to allow operators in types")
545 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
546 forall_head (L _ (HsAppTy ty _)) = forall_head ty
547 forall_head _other = False
548 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)