Reject negative type-level integers created via TH (#8412)
[ghc.git] / compiler / rename / RnTypes.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
7 module RnTypes (
8         -- Type related stuff
9         rnHsType, rnLHsType, rnLHsTypes, rnContext,
10         rnHsKind, rnLHsKind, rnLHsMaybeKind,
11         rnHsSigType, rnLHsInstType, rnConDeclFields,
12         newTyVarNameRn,
13
14         -- Precence related stuff
15         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
16         checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
17
18         -- Binding related stuff
19         bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
20         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
21         extractRdrKindSigVars, extractDataDefnKindVars, filterInScope
22   ) where
23
24 #ifdef GHCI
25 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
26 #endif /* GHCI */
27 import {-# SOURCE #-} RnSplice( rnSpliceType )
28
29 import DynFlags
30 import HsSyn
31 import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
32 import RnEnv
33 import TcRnMonad
34 import RdrName
35 import PrelNames
36 import TysPrim          ( funTyConName )
37 import Name
38 import SrcLoc
39 import NameSet
40
41 import Util
42 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
43                           Fixity(..), FixityDirection(..) )
44 import Outputable
45 import FastString
46 import Maybes
47 import Data.List        ( nub )
48 import Control.Monad    ( unless, when )
49
50 #include "HsVersions.h"
51 \end{code}
52
53 These type renamers are in a separate module, rather than in (say) RnSource,
54 to break several loop.
55
56 %*********************************************************
57 %*                                                      *
58 \subsection{Renaming types}
59 %*                                                      *
60 %*********************************************************
61
62 \begin{code}
63 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
64         -- rnHsSigType is used for source-language type signatures,
65         -- which use *implicit* universal quantification.
66 rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
67
68 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
69 -- Rename the type in an instance or standalone deriving decl
70 rnLHsInstType doc_str ty
71   = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
72        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
73        ; return (ty', fvs) }
74   where
75     good_inst_ty
76       | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
77       , isTcOcc (rdrNameOcc cls) = True
78       | otherwise                = False
79
80 badInstTy :: LHsType RdrName -> SDoc
81 badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
82 \end{code}
83
84 rnHsType is here because we call it from loadInstDecl, and I didn't
85 want a gratuitous knot.
86
87 \begin{code}
88 rnLHsTyKi  :: Bool --  True <=> renaming a type, False <=> a kind
89            -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
90 rnLHsTyKi isType doc (L loc ty)
91   = setSrcSpan loc $
92     do { (ty', fvs) <- rnHsTyKi isType doc ty
93        ; return (L loc ty', fvs) }
94
95 rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
96 rnLHsType = rnLHsTyKi True
97
98 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
99 rnLHsKind = rnLHsTyKi False
100
101 rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
102                 -> RnM (Maybe (LHsKind Name), FreeVars)
103 rnLHsMaybeKind _ Nothing
104   = return (Nothing, emptyFVs)
105 rnLHsMaybeKind doc (Just kind)
106   = do { (kind', fvs) <- rnLHsKind doc kind
107        ; return (Just kind', fvs) }
108
109 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
110 rnHsType = rnHsTyKi True
111 rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
112 rnHsKind = rnHsTyKi False
113
114 rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
115
116 rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
117   = ASSERT( isType ) do
118         -- Implicit quantifiction in source code (no kinds on tyvars)
119         -- Given the signature  C => T  we universally quantify
120         -- over FV(T) \ {in-scope-tyvars}
121     rdr_env <- getLocalRdrEnv
122     loc <- getSrcSpanM
123     let
124         (forall_kvs, forall_tvs) = filterInScope rdr_env $
125                                    extractHsTysRdrTyVars (ty:ctxt)
126            -- In for-all types we don't bring in scope
127            -- kind variables mentioned in kind signatures
128            -- (Well, not yet anyway....)
129            --    f :: Int -> T (a::k)    -- Not allowed
130
131            -- The filterInScope is to ensure that we don't quantify over
132            -- type variables that are in scope; when GlasgowExts is off,
133            -- there usually won't be any, except for class signatures:
134            --   class C a where { op :: a -> a }
135         tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
136
137     rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
138
139 rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
140   = ASSERT( isType ) do {      -- Explicit quantification.
141          -- Check that the forall'd tyvars are actually
142          -- mentioned in the type, and produce a warning if not
143          let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
144              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
145        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
146
147        ; rnForAll doc Explicit kvs forall_tyvars lctxt tau }
148
149 rnHsTyKi isType _ (HsTyVar rdr_name)
150   = do { name <- rnTyVar isType rdr_name
151        ; return (HsTyVar name, unitFV name) }
152
153 -- If we see (forall a . ty), without foralls on, the forall will give
154 -- a sensible error message, but we don't want to complain about the dot too
155 -- Hence the jiggery pokery with ty1
156 rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
157   = ASSERT( isType ) setSrcSpan loc $
158     do  { ops_ok <- xoptM Opt_TypeOperators
159         ; op' <- if ops_ok
160                  then rnTyVar isType op
161                  else do { addErr (opTyErr op ty)
162                          ; return (mkUnboundName op) }  -- Avoid double complaint
163         ; let l_op' = L loc op'
164         ; fix <- lookupTyFixityRn l_op'
165         ; (ty1', fvs1) <- rnLHsType doc ty1
166         ; (ty2', fvs2) <- rnLHsType doc ty2
167         ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
168                                op' fix ty1' ty2'
169         ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
170
171 rnHsTyKi isType doc (HsParTy ty)
172   = do { (ty', fvs) <- rnLHsTyKi isType doc ty
173        ; return (HsParTy ty', fvs) }
174
175 rnHsTyKi isType doc (HsBangTy b ty)
176   = ASSERT( isType )
177     do { (ty', fvs) <- rnLHsType doc ty
178        ; return (HsBangTy b ty', fvs) }
179
180 rnHsTyKi _ doc ty@(HsRecTy flds)
181   = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
182                     2 (ppr ty))
183        ; (flds', fvs) <- rnConDeclFields doc flds
184        ; return (HsRecTy flds', fvs) }
185
186 rnHsTyKi isType doc (HsFunTy ty1 ty2)
187   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
188         -- Might find a for-all as the arg of a function type
189        ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
190         -- Or as the result.  This happens when reading Prelude.hi
191         -- when we find return :: forall m. Monad m -> forall a. a -> m a
192
193         -- Check for fixity rearrangements
194        ; res_ty <- if isType
195                    then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
196                    else return (HsFunTy ty1' ty2')
197        ; return (res_ty, fvs1 `plusFV` fvs2) }
198
199 rnHsTyKi isType doc listTy@(HsListTy ty)
200   = do { data_kinds <- xoptM Opt_DataKinds
201        ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
202        ; (ty', fvs) <- rnLHsTyKi isType doc ty
203        ; return (HsListTy ty', fvs) }
204
205 rnHsTyKi isType doc (HsKindSig ty k)
206   = ASSERT( isType )
207     do { kind_sigs_ok <- xoptM Opt_KindSignatures
208        ; unless kind_sigs_ok (badSigErr False doc ty)
209        ; (ty', fvs1) <- rnLHsType doc ty
210        ; (k', fvs2) <- rnLHsKind doc k
211        ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
212
213 rnHsTyKi isType doc (HsPArrTy ty)
214   = ASSERT( isType )
215     do { (ty', fvs) <- rnLHsType doc ty
216        ; return (HsPArrTy ty', fvs) }
217
218 -- Unboxed tuples are allowed to have poly-typed arguments.  These
219 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
220 rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
221   = do { data_kinds <- xoptM Opt_DataKinds
222        ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
223        ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
224        ; return (HsTupleTy tup_con tys', fvs) }
225
226 -- Perhaps we should use a separate extension here?
227 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
228 rnHsTyKi isType _ tyLit@(HsTyLit t)
229   = do { data_kinds <- xoptM Opt_DataKinds
230        ; unless (data_kinds || isType) (addErr (dataKindsErr isType tyLit))
231        ; when (negLit t) (addErr negLitErr)
232        ; return (HsTyLit t, emptyFVs) }
233   where
234     negLit (HsStrTy _) = False
235     negLit (HsNumTy i) = i < 0
236     negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
237
238 rnHsTyKi isType doc (HsAppTy ty1 ty2)
239   = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
240        ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
241        ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
242
243 rnHsTyKi isType doc (HsIParamTy n ty)
244   = ASSERT( isType )
245     do { (ty', fvs) <- rnLHsType doc ty
246        ; return (HsIParamTy n ty', fvs) }
247
248 rnHsTyKi isType doc (HsEqTy ty1 ty2)
249   = ASSERT( isType )
250     do { (ty1', fvs1) <- rnLHsType doc ty1
251        ; (ty2', fvs2) <- rnLHsType doc ty2
252        ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
253
254 rnHsTyKi isType _ (HsSpliceTy sp _ k)
255   = ASSERT( isType )
256     rnSpliceType sp k
257
258 rnHsTyKi isType doc (HsDocTy ty haddock_doc)
259   = ASSERT( isType )
260     do { (ty', fvs) <- rnLHsType doc ty
261        ; haddock_doc' <- rnLHsDoc haddock_doc
262        ; return (HsDocTy ty' haddock_doc', fvs) }
263
264 #ifndef GHCI
265 rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
266 #else
267 rnHsTyKi isType doc (HsQuasiQuoteTy qq)
268   = ASSERT( isType )
269     do { ty <- runQuasiQuoteType qq
270          -- Wrap the result of the quasi-quoter in parens so that we don't
271          -- lose the outermost location set by runQuasiQuote (#7918) 
272        ; rnHsType doc (HsParTy ty) }
273 #endif
274
275 rnHsTyKi isType _ (HsCoreTy ty)
276   = ASSERT( isType )
277     return (HsCoreTy ty, emptyFVs)
278     -- The emptyFVs probably isn't quite right
279     -- but I don't think it matters
280
281 rnHsTyKi _ _ (HsWrapTy {})
282   = panic "rnHsTyKi"
283
284 rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
285   = ASSERT( isType )
286     do { data_kinds <- xoptM Opt_DataKinds
287        ; unless data_kinds (addErr (dataKindsErr isType ty))
288        ; (tys', fvs) <- rnLHsTypes doc tys
289        ; return (HsExplicitListTy k tys', fvs) }
290
291 rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
292   = ASSERT( isType )
293     do { data_kinds <- xoptM Opt_DataKinds
294        ; unless data_kinds (addErr (dataKindsErr isType ty))
295        ; (tys', fvs) <- rnLHsTypes doc tys
296        ; return (HsExplicitTupleTy kis tys', fvs) }
297
298 --------------
299 rnTyVar :: Bool -> RdrName -> RnM Name
300 rnTyVar is_type rdr_name
301   | is_type   = lookupTypeOccRn rdr_name
302   | otherwise = lookupKindOccRn rdr_name
303
304
305 --------------
306 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
307            -> RnM ([LHsType Name], FreeVars)
308 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
309 \end{code}
310
311
312 \begin{code}
313 rnForAll :: HsDocContext -> HsExplicitFlag
314          -> [RdrName]                -- Kind variables
315          -> LHsTyVarBndrs RdrName   -- Type variables
316          -> LHsContext RdrName -> LHsType RdrName
317          -> RnM (HsType Name, FreeVars)
318
319 rnForAll doc exp kvs forall_tyvars ctxt ty
320   | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
321   = rnHsType doc (unLoc ty)
322         -- One reason for this case is that a type like Int#
323         -- starts off as (HsForAllTy Nothing [] Int), in case
324         -- there is some quantification.  Now that we have quantified
325         -- and discovered there are no type variables, it's nicer to turn
326         -- it into plain Int.  If it were Int# instead of Int, we'd actually
327         -- get an error, because the body of a genuine for-all is
328         -- of kind *.
329
330   | otherwise
331   = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
332     do { (new_ctxt, fvs1) <- rnContext doc ctxt
333        ; (new_ty, fvs2) <- rnLHsType doc ty
334        ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
335         -- Retain the same implicit/explicit flag as before
336         -- so that we can later print it correctly
337
338 ---------------
339 bindSigTyVarsFV :: [Name]
340                 -> RnM (a, FreeVars)
341                 -> RnM (a, FreeVars)
342 -- Used just before renaming the defn of a function
343 -- with a separate type signature, to bring its tyvars into scope
344 -- With no -XScopedTypeVariables, this is a no-op
345 bindSigTyVarsFV tvs thing_inside
346   = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
347         ; if not scoped_tyvars then
348                 thing_inside
349           else
350                 bindLocalNamesFV tvs thing_inside }
351
352 ---------------
353 bindHsTyVars :: HsDocContext
354              -> Maybe a                 -- Just _  => an associated type decl
355              -> [RdrName]               -- Kind variables from scope
356              -> LHsTyVarBndrs RdrName   -- Type variables
357              -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
358              -> RnM (b, FreeVars)
359 -- (a) Bring kind variables into scope
360 --     both (i)  passed in (kv_bndrs)
361 --     and  (ii) mentioned in the kinds of tv_bndrs
362 -- (b) Bring type variables into scope
363 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
364   = do { rdr_env <- getLocalRdrEnv
365        ; let tvs = hsQTvBndrs tv_bndrs
366              kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
367                                  , let (_, kvs) = extractHsTyRdrTyVars kind
368                                  , kv <- kvs ]
369              all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
370                        nub (kv_bndrs ++ kvs_from_tv_bndrs)
371              overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
372                 -- These variables appear both as kind and type variables
373                 -- in the same declaration; eg  type family  T (x :: *) (y :: x)
374                 -- We disallow this: too confusing!
375
376        ; poly_kind <- xoptM Opt_PolyKinds
377        ; unless (poly_kind || null all_kvs)
378                 (addErr (badKindBndrs doc all_kvs))
379        ; unless (null overlap_kvs)
380                 (addErr (overlappingKindVars doc overlap_kvs))
381
382        ; loc <- getSrcSpanM
383        ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
384        ; bindLocalNamesFV kv_names $
385     do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
386
387              rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
388              rn_tv_bndr (L loc (UserTyVar rdr))
389                = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
390                     ; return (L loc (UserTyVar nm), emptyFVs) }
391              rn_tv_bndr (L loc (KindedTyVar rdr kind))
392                = do { sig_ok <- xoptM Opt_KindSignatures
393                     ; unless sig_ok (badSigErr False doc kind)
394                     ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
395                     ; (kind', fvs) <- rnLHsKind doc kind
396                     ; return (L loc (KindedTyVar nm kind'), fvs) }
397
398        -- Check for duplicate or shadowed tyvar bindrs
399        ; checkDupRdrNames tv_names_w_loc
400        ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
401
402        ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
403        ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
404                         do { env <- getLocalRdrEnv
405                            ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
406                            ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
407        ; return (res, fvs1 `plusFV` fvs2) } }
408
409 newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
410 newTyVarNameRn mb_assoc rdr_env loc rdr
411   | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
412   , Just n <- lookupLocalRdrEnv rdr_env rdr
413   = return n
414   | otherwise
415   = newLocalBndrRn (L loc rdr)
416
417 --------------------------------
418 rnHsBndrSig :: HsDocContext
419             -> HsWithBndrs (LHsType RdrName)
420             -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
421             -> RnM (a, FreeVars)
422 rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
423   = do { sig_ok <- xoptM Opt_ScopedTypeVariables
424        ; unless sig_ok (badSigErr True doc ty)
425        ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
426        ; name_env <- getLocalRdrEnv
427        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
428                                                , not (tv `elemLocalRdrEnv` name_env) ]
429        ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
430                                                , not (kv `elemLocalRdrEnv` name_env) ]
431        ; bindLocalNamesFV kv_names $
432          bindLocalNamesFV tv_names $
433     do { (ty', fvs1) <- rnLHsType doc ty
434        ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
435        ; return (res, fvs1 `plusFV` fvs2) } }
436
437 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
438 overlappingKindVars doc kvs
439   = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
440            ptext (sLit "also used as type variable") <> plural kvs
441            <> colon <+> pprQuotedList kvs
442          , docOfHsDocContext doc ]
443
444 badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
445 badKindBndrs doc kvs
446   = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
447                  <+> pprQuotedList kvs)
448               2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
449          , docOfHsDocContext doc ]
450
451 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
452 badSigErr is_type doc (L loc ty)
453   = setSrcSpan loc $ addErr $
454     vcat [ hang (ptext (sLit "Illegal") <+> what
455                  <+> ptext (sLit "signature:") <+> quotes (ppr ty))
456               2 (ptext (sLit "Perhaps you intended to use") <+> flag)
457          , docOfHsDocContext doc ]
458   where
459     what | is_type   = ptext (sLit "type")
460          | otherwise = ptext (sLit "kind")
461     flag | is_type   = ptext (sLit "ScopedTypeVariables")
462          | otherwise = ptext (sLit "KindSignatures")
463
464 dataKindsErr :: Bool -> HsType RdrName -> SDoc
465 dataKindsErr is_type thing
466   = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
467        2 (ptext (sLit "Perhaps you intended to use DataKinds"))
468   where
469     what | is_type   = ptext (sLit "type")
470          | otherwise = ptext (sLit "kind")
471 \end{code}
472
473 Note [Renaming associated types]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 Check that the RHS of the decl mentions only type variables
476 bound on the LHS.  For example, this is not ok
477    class C a b where
478       type F a x :: *
479    instance C (p,q) r where
480       type F (p,q) x = (x, r)   -- BAD: mentions 'r'
481 c.f. Trac #5515
482
483 What makes it tricky is that the *kind* variable from the class *are*
484 in scope (Trac #5862):
485     class Category (x :: k -> k -> *) where
486       type Ob x :: k -> Constraint
487       id :: Ob x a => x a a
488       (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
489 Here 'k' is in scope in the kind signature even though it's not
490 explicitly mentioned on the LHS of the type Ob declaration.
491
492 We could force you to mention k explicitly, thus
493     class Category (x :: k -> k -> *) where
494       type Ob (x :: k -> k -> *) :: k -> Constraint
495 but it seems tiresome to do so.
496
497
498 %*********************************************************
499 %*                                                      *
500 \subsection{Contexts and predicates}
501 %*                                                      *
502 %*********************************************************
503
504 \begin{code}
505 rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
506                 -> RnM ([ConDeclField Name], FreeVars)
507 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
508
509 rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
510 rnField doc (ConDeclField name ty haddock_doc)
511   = do { new_name <- lookupLocatedTopBndrRn name
512        ; (new_ty, fvs) <- rnLHsType doc ty
513        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
514        ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
515
516 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
517 rnContext doc (L loc cxt)
518   = do { (cxt', fvs) <- rnLHsTypes doc cxt
519        ; return (L loc cxt', fvs) }
520 \end{code}
521
522
523 %************************************************************************
524 %*                                                                      *
525         Fixities and precedence parsing
526 %*                                                                      *
527 %************************************************************************
528
529 @mkOpAppRn@ deals with operator fixities.  The argument expressions
530 are assumed to be already correctly arranged.  It needs the fixities
531 recorded in the OpApp nodes, because fixity info applies to the things
532 the programmer actually wrote, so you can't find it out from the Name.
533
534 Furthermore, the second argument is guaranteed not to be another
535 operator application.  Why? Because the parser parses all
536 operator appications left-associatively, EXCEPT negation, which
537 we need to handle specially.
538 Infix types are read in a *right-associative* way, so that
539         a `op` b `op` c
540 is always read in as
541         a `op` (b `op` c)
542
543 mkHsOpTyRn rearranges where necessary.  The two arguments
544 have already been renamed and rearranged.  It's made rather tiresome
545 by the presence of ->, which is a separate syntactic construct.
546
547 \begin{code}
548 ---------------
549 -- Building (ty1 `op1` (ty21 `op2` ty22))
550 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
551            -> Name -> Fixity -> LHsType Name -> LHsType Name
552            -> RnM (HsType Name)
553
554 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
555   = do  { fix2 <- lookupTyFixityRn op2
556         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
557                       (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
558                       (unLoc op2) fix2 ty21 ty22 loc2 }
559
560 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
561   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
562                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
563
564 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
565   = return (mk1 ty1 ty2)
566
567 ---------------
568 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
569             -> Name -> Fixity -> LHsType Name
570             -> (LHsType Name -> LHsType Name -> HsType Name)
571             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
572             -> RnM (HsType Name)
573 mk_hs_op_ty mk1 op1 fix1 ty1
574             mk2 op2 fix2 ty21 ty22 loc2
575   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
576                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
577   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
578   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
579                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
580                          ; return (mk2 (noLoc new_ty) ty22) }
581   where
582     (nofix_error, associate_right) = compareFixity fix1 fix2
583
584
585 ---------------------------
586 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
587           -> LHsExpr Name -> Fixity             -- Operator and fixity
588           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
589                                                 -- be a NegApp)
590           -> RnM (HsExpr Name)
591
592 -- (e11 `op1` e12) `op2` e2
593 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
594   | nofix_error
595   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
596        return (OpApp e1 op2 fix2 e2)
597
598   | associate_right = do
599     new_e <- mkOpAppRn e12 op2 fix2 e2
600     return (OpApp e11 op1 fix1 (L loc' new_e))
601   where
602     loc'= combineLocs e12 e2
603     (nofix_error, associate_right) = compareFixity fix1 fix2
604
605 ---------------------------
606 --      (- neg_arg) `op` e2
607 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
608   | nofix_error
609   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
610        return (OpApp e1 op2 fix2 e2)
611
612   | associate_right
613   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
614        return (NegApp (L loc' new_e) neg_name)
615   where
616     loc' = combineLocs neg_arg e2
617     (nofix_error, associate_right) = compareFixity negateFixity fix2
618
619 ---------------------------
620 --      e1 `op` - neg_arg
621 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
622   | not associate_right                 -- We *want* right association
623   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
624        return (OpApp e1 op1 fix1 e2)
625   where
626     (_, associate_right) = compareFixity fix1 negateFixity
627
628 ---------------------------
629 --      Default case
630 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
631   = ASSERT2( right_op_ok fix (unLoc e2),
632              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
633     )
634     return (OpApp e1 op fix e2)
635
636 ----------------------------
637 get_op :: LHsExpr Name -> Name
638 get_op (L _ (HsVar n)) = n
639 get_op other           = pprPanic "get_op" (ppr other)
640
641 -- Parser left-associates everything, but
642 -- derived instances may have correctly-associated things to
643 -- in the right operarand.  So we just check that the right operand is OK
644 right_op_ok :: Fixity -> HsExpr Name -> Bool
645 right_op_ok fix1 (OpApp _ _ fix2 _)
646   = not error_please && associate_right
647   where
648     (error_please, associate_right) = compareFixity fix1 fix2
649 right_op_ok _ _
650   = True
651
652 -- Parser initially makes negation bind more tightly than any other operator
653 -- And "deriving" code should respect this (use HsPar if not)
654 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
655 mkNegAppRn neg_arg neg_name
656   = ASSERT( not_op_app (unLoc neg_arg) )
657     return (NegApp neg_arg neg_name)
658
659 not_op_app :: HsExpr id -> Bool
660 not_op_app (OpApp _ _ _ _) = False
661 not_op_app _               = True
662
663 ---------------------------
664 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
665           -> LHsExpr Name -> Fixity     -- Operator and fixity
666           -> LHsCmdTop Name             -- Right operand (not an infix)
667           -> RnM (HsCmd Name)
668
669 -- (e11 `op1` e12) `op2` e2
670 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
671         op2 fix2 a2
672   | nofix_error
673   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
674        return (HsCmdArrForm op2 (Just fix2) [a1, a2])
675
676   | associate_right
677   = do new_c <- mkOpFormRn a12 op2 fix2 a2
678        return (HsCmdArrForm op1 (Just fix1)
679                   [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])])
680         -- TODO: locs are wrong
681   where
682     (nofix_error, associate_right) = compareFixity fix1 fix2
683
684 --      Default case
685 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
686   = return (HsCmdArrForm op (Just fix) [arg1, arg2])
687
688
689 --------------------------------------
690 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
691              -> RnM (Pat Name)
692
693 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
694   = do  { fix1 <- lookupFixityRn (unLoc op1)
695         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
696
697         ; if nofix_error then do
698                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
699                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
700
701           else if associate_right then do
702                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
703                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
704           else return (ConPatIn op2 (InfixCon p1 p2)) }
705
706 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
707   = ASSERT( not_op_pat (unLoc p2) )
708     return (ConPatIn op (InfixCon p1 p2))
709
710 not_op_pat :: Pat Name -> Bool
711 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
712 not_op_pat _                           = True
713
714 --------------------------------------
715 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
716   -- Check precedence of a function binding written infix
717   --   eg  a `op` b `C` c = ...
718   -- See comments with rnExpr (OpApp ...) about "deriving"
719
720 checkPrecMatch op (MG { mg_alts = ms })
721   = mapM_ check ms
722   where
723     check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
724       = setSrcSpan (combineSrcSpans l1 l2) $
725         do checkPrec op p1 False
726            checkPrec op p2 True
727
728     check _ = return ()
729         -- This can happen.  Consider
730         --      a `op` True = ...
731         --      op          = ...
732         -- The infix flag comes from the first binding of the group
733         -- but the second eqn has no args (an error, but not discovered
734         -- until the type checker).  So we don't want to crash on the
735         -- second eqn.
736
737 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
738 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
739     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
740     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
741     let
742         inf_ok = op1_prec > op_prec ||
743                  (op1_prec == op_prec &&
744                   (op1_dir == InfixR && op_dir == InfixR && right ||
745                    op1_dir == InfixL && op_dir == InfixL && not right))
746
747         info  = (op,        op_fix)
748         info1 = (unLoc op1, op1_fix)
749         (infol, infor) = if right then (info, info1) else (info1, info)
750     unless inf_ok (precParseErr infol infor)
751
752 checkPrec _ _ _
753   = return ()
754
755 -- Check precedence of (arg op) or (op arg) respectively
756 -- If arg is itself an operator application, then either
757 --   (a) its precedence must be higher than that of op
758 --   (b) its precedency & associativity must be the same as that of op
759 checkSectionPrec :: FixityDirection -> HsExpr RdrName
760         -> LHsExpr Name -> LHsExpr Name -> RnM ()
761 checkSectionPrec direction section op arg
762   = case unLoc arg of
763         OpApp _ op fix _ -> go_for_it (get_op op) fix
764         NegApp _ _       -> go_for_it negateName  negateFixity
765         _                -> return ()
766   where
767     op_name = get_op op
768     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
769           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
770           unless (op_prec < arg_prec
771                   || (op_prec == arg_prec && direction == assoc))
772                  (sectionPrecErr (op_name, op_fix)
773                                  (arg_op, arg_fix) section)
774 \end{code}
775
776 Precedence-related error messages
777
778 \begin{code}
779 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
780 precParseErr op1@(n1,_) op2@(n2,_)
781   | isUnboundName n1 || isUnboundName n2
782   = return ()     -- Avoid error cascade
783   | otherwise
784   = addErr $ hang (ptext (sLit "Precedence parsing error"))
785       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
786                ppr_opfix op2,
787                ptext (sLit "in the same infix expression")])
788
789 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
790 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
791   | isUnboundName n1 || isUnboundName n2
792   = return ()     -- Avoid error cascade
793   | otherwise
794   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
795          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
796                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
797          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
798
799 ppr_opfix :: (Name, Fixity) -> SDoc
800 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
801    where
802      pp_op | op == negateName = ptext (sLit "prefix `-'")
803            | otherwise        = quotes (ppr op)
804 \end{code}
805
806 %*********************************************************
807 %*                                                      *
808 \subsection{Errors}
809 %*                                                      *
810 %*********************************************************
811
812 \begin{code}
813 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
814 warnUnusedForAlls in_doc bound mentioned_rdrs
815   = whenWOptM Opt_WarnUnusedMatches $
816     mapM_ add_warn bound_but_not_used
817   where
818     bound_names        = hsLTyVarLocNames bound
819     bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
820
821     add_warn (L loc tv)
822       = addWarnAt loc $
823         vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
824              , in_doc ]
825
826 opTyErr :: RdrName -> HsType RdrName -> SDoc
827 opTyErr op ty@(HsOpTy ty1 _ _)
828   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
829          2 extra
830   where
831     extra | op == dot_tv_RDR && forall_head ty1
832           = perhapsForallMsg
833           | otherwise
834           = ptext (sLit "Use TypeOperators to allow operators in types")
835
836     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
837     forall_head (L _ (HsAppTy ty _)) = forall_head ty
838     forall_head _other               = False
839 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
840 \end{code}
841
842 %************************************************************************
843 %*                                                                      *
844       Finding the free type variables of a (HsType RdrName)
845 %*                                                                    *
846 %************************************************************************
847
848
849 Note [Kind and type-variable binders]
850 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
851 In a type signature we may implicitly bind type varaible and, more
852 recently, kind variables.  For example:
853   *   f :: a -> a
854       f = ...
855     Here we need to find the free type variables of (a -> a),
856     so that we know what to quantify
857
858   *   class C (a :: k) where ...
859     This binds 'k' in ..., as well as 'a'
860
861   *   f (x :: a -> [a]) = ....
862     Here we bind 'a' in ....
863
864   *   f (x :: T a -> T (b :: k)) = ...
865     Here we bind both 'a' and the kind variable 'k'
866
867   *   type instance F (T (a :: Maybe k)) = ...a...k...
868     Here we want to constrain the kind of 'a', and bind 'k'.
869
870 In general we want to walk over a type, and find
871   * Its free type variables
872   * The free kind variables of any kind signatures in the type
873
874 Hence we returns a pair (kind-vars, type vars)
875 See also Note [HsBSig binder lists] in HsTypes
876
877 \begin{code}
878 type FreeKiTyVars = ([RdrName], [RdrName])
879
880 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
881 filterInScope rdr_env (kvs, tvs)
882   = (filterOut in_scope kvs, filterOut in_scope tvs)
883   where
884     in_scope tv = tv `elemLocalRdrEnv` rdr_env
885
886 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
887 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
888 --                        or the free (sort, kind) variables of a HsKind
889 -- It's used when making the for-alls explicit.
890 -- See Note [Kind and type-variable binders]
891 extractHsTyRdrTyVars ty
892   = case extract_lty ty ([],[]) of
893      (kvs, tvs) -> (nub kvs, nub tvs)
894
895 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
896 -- See Note [Kind and type-variable binders]
897 extractHsTysRdrTyVars ty
898   = case extract_ltys ty ([],[]) of
899      (kvs, tvs) -> (nub kvs, nub tvs)
900
901 extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
902 extractRdrKindSigVars Nothing = []
903 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
904
905 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
906 -- Get the scoped kind variables mentioned free in the constructor decls
907 -- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
908 -- Here k should scope over the whole definition
909 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
910                                     , dd_cons = cons, dd_derivs = derivs })
911   = fst $ extract_lctxt ctxt $
912           extract_mb extract_lkind ksig $
913           extract_mb extract_ltys derivs $
914           foldr (extract_con . unLoc) ([],[]) cons
915   where
916     extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
917     extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
918                          , con_cxt = ctxt, con_details = details }) acc
919       = extract_hs_tv_bndrs qvs acc $
920         extract_lctxt ctxt $
921         extract_ltys (hsConDeclArgTys details) ([],[])
922
923
924 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
925 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
926
927 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
928 extract_ltys tys acc = foldr extract_lty acc tys
929
930 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
931 extract_mb _ Nothing  acc = acc
932 extract_mb f (Just x) acc = f x acc
933
934 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
935 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
936                                           (_, res_kvs) -> (res_kvs, acc_tvs)
937                                         -- Kinds shouldn't have sort signatures!
938
939 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
940 extract_lty (L _ ty) acc
941   = case ty of
942       HsTyVar tv                -> extract_tv tv acc
943       HsBangTy _ ty             -> extract_lty ty acc
944       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
945       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
946       HsListTy ty               -> extract_lty ty acc
947       HsPArrTy ty               -> extract_lty ty acc
948       HsTupleTy _ tys           -> extract_ltys tys acc
949       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
950       HsIParamTy _ ty           -> extract_lty ty acc
951       HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
952       HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
953       HsParTy ty                -> extract_lty ty acc
954       HsCoreTy {}               -> acc  -- The type is closed
955       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
956       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
957       HsDocTy ty _              -> extract_lty ty acc
958       HsExplicitListTy _ tys    -> extract_ltys tys acc
959       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
960       HsTyLit _                 -> acc
961       HsWrapTy _ _              -> panic "extract_lty"
962       HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
963       HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
964                                    extract_lctxt cx   $
965                                    extract_lty ty ([],[])
966
967 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
968                     -> FreeKiTyVars -> FreeKiTyVars
969 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
970                     (acc_kvs, acc_tvs)   -- Note accumulator comes first
971                     (body_kvs, body_tvs)
972   | null tvs
973   = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
974   | otherwise
975   = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
976      acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
977   where
978     local_tvs = map hsLTyVarName tvs
979     (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
980        -- These kind variables are bound here if not bound further out
981
982 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
983 extract_tv tv acc
984   | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
985   | otherwise     = acc
986 \end{code}