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)
152 = do { kind_sigs_ok <- doptM Opt_KindSignatures
153 ; checkM kind_sigs_ok (addErr (kindSigErr ty))
154 ; ty' <- rnLHsType doc ty
155 ; return (HsKindSig ty' k) }
157 rnHsType doc (HsPArrTy ty) = do
158 ty' <- rnLHsType doc ty
159 return (HsPArrTy ty')
161 -- Unboxed tuples are allowed to have poly-typed arguments. These
162 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
163 rnHsType doc (HsTupleTy tup_con tys) = do
164 tys' <- mapM (rnLHsType doc) tys
165 return (HsTupleTy tup_con tys')
167 rnHsType doc (HsAppTy ty1 ty2) = do
168 ty1' <- rnLHsType doc ty1
169 ty2' <- rnLHsType doc ty2
170 return (HsAppTy ty1' ty2')
172 rnHsType doc (HsPredTy pred) = do
173 pred' <- rnPred doc pred
174 return (HsPredTy pred')
176 rnHsType _ (HsSpliceTy _) =
177 failWith (ptext (sLit "Type splices are not yet implemented"))
179 rnHsType doc (HsDocTy ty haddock_doc) = do
180 ty' <- rnLHsType doc ty
181 haddock_doc' <- rnLHsDoc haddock_doc
182 return (HsDocTy ty' haddock_doc')
184 rnLHsTypes :: SDoc -> [LHsType RdrName]
185 -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
186 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
191 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
192 -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
194 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
195 -- One reason for this case is that a type like Int#
196 -- starts off as (HsForAllTy Nothing [] Int), in case
197 -- there is some quantification. Now that we have quantified
198 -- and discovered there are no type variables, it's nicer to turn
199 -- it into plain Int. If it were Int# instead of Int, we'd actually
200 -- get an error, because the body of a genuine for-all is
203 rnForAll doc exp forall_tyvars ctxt ty
204 = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
205 new_ctxt <- rnContext doc ctxt
206 new_ty <- rnLHsType doc ty
207 return (HsForAllTy exp new_tyvars new_ctxt new_ty)
208 -- Retain the same implicit/explicit flag as before
209 -- so that we can later print it correctly
212 %*********************************************************
214 \subsection{Contexts and predicates}
216 %*********************************************************
219 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
220 rnContext doc = wrapLocM (rnContext' doc)
222 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
223 rnContext' doc ctxt = mapM (rnLPred doc) ctxt
225 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
226 rnLPred doc = wrapLocM (rnPred doc)
228 rnPred :: SDoc -> HsPred RdrName
229 -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
230 rnPred doc (HsClassP clas tys)
231 = do { clas_name <- lookupOccRn clas
232 ; tys' <- rnLHsTypes doc tys
233 ; return (HsClassP clas_name tys')
235 rnPred doc (HsEqualP ty1 ty2)
236 = do { ty1' <- rnLHsType doc ty1
237 ; ty2' <- rnLHsType doc ty2
238 ; return (HsEqualP ty1' ty2')
240 rnPred doc (HsIParam n ty)
241 = do { name <- newIPNameRn n
242 ; ty' <- rnLHsType doc ty
243 ; return (HsIParam name ty')
248 %************************************************************************
250 Fixities and precedence parsing
252 %************************************************************************
254 @mkOpAppRn@ deals with operator fixities. The argument expressions
255 are assumed to be already correctly arranged. It needs the fixities
256 recorded in the OpApp nodes, because fixity info applies to the things
257 the programmer actually wrote, so you can't find it out from the Name.
259 Furthermore, the second argument is guaranteed not to be another
260 operator application. Why? Because the parser parses all
261 operator appications left-associatively, EXCEPT negation, which
262 we need to handle specially.
263 Infix types are read in a *right-associative* way, so that
268 mkHsOpTyRn rearranges where necessary. The two arguments
269 have already been renamed and rearranged. It's made rather tiresome
270 by the presence of ->, which is a separate syntactic construct.
274 -- Building (ty1 `op1` (ty21 `op2` ty22))
275 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
276 -> Name -> Fixity -> LHsType Name -> LHsType Name
279 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
280 = do { fix2 <- lookupTyFixityRn op2
281 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
282 (\t1 t2 -> HsOpTy t1 op2 t2)
283 (unLoc op2) fix2 ty21 ty22 loc2 }
285 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
286 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
287 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
289 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
290 = return (mk1 ty1 ty2)
293 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
294 -> Name -> Fixity -> LHsType Name
295 -> (LHsType Name -> LHsType Name -> HsType Name)
296 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
298 mk_hs_op_ty mk1 op1 fix1 ty1
299 mk2 op2 fix2 ty21 ty22 loc2
300 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
301 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
302 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
303 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
304 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
305 ; return (mk2 (noLoc new_ty) ty22) }
307 (nofix_error, associate_right) = compareFixity fix1 fix2
310 ---------------------------
311 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
312 -> LHsExpr Name -> Fixity -- Operator and fixity
313 -> LHsExpr Name -- Right operand (not an OpApp, but might
317 -- (e11 `op1` e12) `op2` e2
318 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
320 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
321 return (OpApp e1 op2 fix2 e2)
323 | associate_right = do
324 new_e <- mkOpAppRn e12 op2 fix2 e2
325 return (OpApp e11 op1 fix1 (L loc' new_e))
327 loc'= combineLocs e12 e2
328 (nofix_error, associate_right) = compareFixity fix1 fix2
330 ---------------------------
331 -- (- neg_arg) `op` e2
332 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
334 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
335 return (OpApp e1 op2 fix2 e2)
338 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
339 return (NegApp (L loc' new_e) neg_name)
341 loc' = combineLocs neg_arg e2
342 (nofix_error, associate_right) = compareFixity negateFixity fix2
344 ---------------------------
346 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
347 | not associate_right -- We *want* right association
348 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
349 return (OpApp e1 op1 fix1 e2)
351 (_, associate_right) = compareFixity fix1 negateFixity
353 ---------------------------
355 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
356 = ASSERT2( right_op_ok fix (unLoc e2),
357 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
359 return (OpApp e1 op fix e2)
361 ----------------------------
362 get_op :: LHsExpr Name -> Name
363 get_op (L _ (HsVar n)) = n
364 get_op other = pprPanic "get_op" (ppr other)
366 -- Parser left-associates everything, but
367 -- derived instances may have correctly-associated things to
368 -- in the right operarand. So we just check that the right operand is OK
369 right_op_ok :: Fixity -> HsExpr Name -> Bool
370 right_op_ok fix1 (OpApp _ _ fix2 _)
371 = not error_please && associate_right
373 (error_please, associate_right) = compareFixity fix1 fix2
377 -- Parser initially makes negation bind more tightly than any other operator
378 -- And "deriving" code should respect this (use HsPar if not)
379 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
380 mkNegAppRn neg_arg neg_name
381 = ASSERT( not_op_app (unLoc neg_arg) )
382 return (NegApp neg_arg neg_name)
384 not_op_app :: HsExpr id -> Bool
385 not_op_app (OpApp _ _ _ _) = False
388 ---------------------------
389 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
390 -> LHsExpr Name -> Fixity -- Operator and fixity
391 -> LHsCmdTop Name -- Right operand (not an infix)
394 -- (e11 `op1` e12) `op2` e2
395 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
398 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
399 return (HsArrForm op2 (Just fix2) [a1, a2])
402 = do new_c <- mkOpFormRn a12 op2 fix2 a2
403 return (HsArrForm op1 (Just fix1)
404 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
405 -- TODO: locs are wrong
407 (nofix_error, associate_right) = compareFixity fix1 fix2
410 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
411 = return (HsArrForm op (Just fix) [arg1, arg2])
414 --------------------------------------
415 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
418 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
419 = do { fix1 <- lookupFixityRn (unLoc op1)
420 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
422 ; if nofix_error then do
423 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
424 ; return (ConPatIn op2 (InfixCon p1 p2)) }
426 else if associate_right then do
427 { new_p <- mkConOpPatRn op2 fix2 p12 p2
428 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
429 else return (ConPatIn op2 (InfixCon p1 p2)) }
431 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
432 = ASSERT( not_op_pat (unLoc p2) )
433 return (ConPatIn op (InfixCon p1 p2))
435 not_op_pat :: Pat Name -> Bool
436 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
439 --------------------------------------
440 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
441 -- True indicates an infix lhs
442 -- See comments with rnExpr (OpApp ...) about "deriving"
444 checkPrecMatch False _ _
446 checkPrecMatch True op (MatchGroup ms _)
449 check (L _ (Match (p1:p2:_) _ _))
450 = do checkPrec op (unLoc p1) False
451 checkPrec op (unLoc p2) True
454 -- This can happen. Consider
457 -- The infix flag comes from the first binding of the group
458 -- but the second eqn has no args (an error, but not discovered
459 -- until the type checker). So we don't want to crash on the
462 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
463 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
464 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
465 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
467 inf_ok = op1_prec > op_prec ||
468 (op1_prec == op_prec &&
469 (op1_dir == InfixR && op_dir == InfixR && right ||
470 op1_dir == InfixL && op_dir == InfixL && not right))
473 info1 = (unLoc op1, op1_fix)
474 (infol, infor) = if right then (info, info1) else (info1, info)
475 unless inf_ok (precParseErr infol infor)
480 -- Check precedence of (arg op) or (op arg) respectively
481 -- If arg is itself an operator application, then either
482 -- (a) its precedence must be higher than that of op
483 -- (b) its precedency & associativity must be the same as that of op
484 checkSectionPrec :: FixityDirection -> HsExpr RdrName
485 -> LHsExpr Name -> LHsExpr Name -> RnM ()
486 checkSectionPrec direction section op arg
488 OpApp _ op fix _ -> go_for_it (get_op op) fix
489 NegApp _ _ -> go_for_it negateName negateFixity
493 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
494 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
495 unless (op_prec < arg_prec
496 || (op_prec == arg_prec && direction == assoc))
497 (sectionPrecErr (op_name, op_fix)
498 (arg_op, arg_fix) section)
501 Precedence-related error messages
504 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
505 precParseErr op1@(n1,_) op2@(n2,_)
506 | isUnboundName n1 || isUnboundName n2
507 = return () -- Avoid error cascade
509 = addErr $ hang (ptext (sLit "Precedence parsing error"))
510 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
512 ptext (sLit "in the same infix expression")])
514 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
515 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
516 | isUnboundName n1 || isUnboundName n2
517 = return () -- Avoid error cascade
519 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
520 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
521 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
522 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
524 ppr_opfix :: (Name, Fixity) -> SDoc
525 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
527 pp_op | op == negateName = ptext (sLit "prefix `-'")
528 | otherwise = quotes (ppr op)
531 %*********************************************************
535 %*********************************************************
538 forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
539 -> TcRnIf TcGblEnv TcLclEnv ()
540 forAllWarn doc ty (L loc tyvar)
541 = ifOptM Opt_WarnUnusedMatches $
542 addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
543 nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
547 opTyErr :: RdrName -> HsType RdrName -> SDoc
548 opTyErr op ty@(HsOpTy ty1 _ _)
549 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
552 extra | op == dot_tv_RDR && forall_head ty1
555 = ptext (sLit "Use -XTypeOperators to allow operators in types")
557 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
558 forall_head (L _ (HsAppTy ty _)) = forall_head ty
559 forall_head _other = False
560 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)