RnSource.hs 103 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[RnSource]{Main pass of renamer}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
9 10
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
11
{-# LANGUAGE ViewPatterns #-}
12

13
module RnSource (
14
        rnSrcDecls, addTcgDUs, findSplice
15
    ) where
16

17
#include "HsVersions.h"
sof's avatar
sof committed
18

19 20
import GhcPrelude

21
import {-# SOURCE #-} RnExpr( rnLExpr )
22
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
23

24
import GHC.Hs
Matthew Pickering's avatar
Matthew Pickering committed
25
import FieldLabel
26
import RdrName
27
import RnTypes
28
import RnBinds
29
import RnEnv
30 31 32
import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
                        , checkShadowedRdrNames, warnUnusedTypePatterns
33 34
                        , extendTyVarEnvFVRn, newLocalBndrsRn
                        , withHsDocContext )
35
import RnUnbound        ( mkUnboundName, notInScopeErr )
36
import RnNames
37
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
38
import TcAnnotations    ( annCtxt )
39
import TcRnMonad
40

41
import ForeignCall      ( CCallTarget(..) )
42
import Module
43
import HscTypes         ( Warnings(..), plusWarns )
44
import PrelNames        ( applicativeClassName, pureAName, thenAName
45 46 47 48
                        , monadClassName, returnMName, thenMName
                        , semigroupClassName, sappendName
                        , monoidClassName, mappendName
                        )
49
import Name
50
import NameSet
51
import NameEnv
52
import Avail
53
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
54
import Bag
55
import BasicTypes       ( pprRuleName, TypeOrKind(..) )
56
import FastString
57
import SrcLoc
58
import DynFlags
59
import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
60
import HscTypes         ( HscEnv, hsc_dflags )
61
import ListSetOps       ( findDupsEq, removeDups, equivClasses )
62
import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
niteria's avatar
niteria committed
63
                        , stronglyConnCompFromEdgedVerticesUniq )
David Feuer's avatar
David Feuer committed
64
import UniqSet
Ryan Scott's avatar
Ryan Scott committed
65
import OrdList
66
import qualified GHC.LanguageExtensions as LangExt
67

68
import Control.Monad
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
69
import Control.Arrow ( first )
70 71 72
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
73
import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
Jan Stolarek's avatar
Jan Stolarek committed
74
import qualified Data.Set as Set ( difference, fromList, toList, null )
75
import Data.Function ( on )
76

Ben Gamari's avatar
Ben Gamari committed
77
{- | @rnSourceDecl@ "renames" declarations.
78 79 80
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:

Ben Gamari's avatar
Ben Gamari committed
81 82 83 84 85 86 87 88 89 90 91 92
* Checks that tyvars are used properly. This includes checking
  for undefined tyvars, and tyvars in contexts that are ambiguous.
  (Some of this checking has now been moved to module @TcMonoType@,
  since we don't have functional dependency information at this point.)

* Checks that all variable occurrences are defined.

* Checks the @(..)@ etc constraints in the export list.

Brings the binders of the group into scope in the appropriate places;
does NOT assume that anything is in scope already
-}
93
rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
94
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
Simon Peyton Jones's avatar
Simon Peyton Jones committed
95 96 97 98 99 100 101 102 103 104 105
rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                            hs_splcds  = splice_decls,
                            hs_tyclds  = tycl_decls,
                            hs_derivds = deriv_decls,
                            hs_fixds   = fix_decls,
                            hs_warnds  = warn_decls,
                            hs_annds   = ann_decls,
                            hs_fords   = foreign_decls,
                            hs_defds   = default_decls,
                            hs_ruleds  = rule_decls,
                            hs_docs    = docs })
106 107 108
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
109
   --     Also checks for duplicates.
110
   local_fix_env <- makeMiniFixityEnv fix_decls ;
111 112

   -- (B) Bring top level binders (and their fixities) into scope,
113 114 115 116 117 118 119 120 121
   --     *except* for the value bindings, which get done in step (D)
   --     with collectHsIdBinders. However *do* include
   --
   --        * Class ops, data constructors, and record fields,
   --          because they do not have value declarations.
   --
   --        * For hs-boot files, include the value signatures
   --          Again, they have no value declarations
   --
122
   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
123

Matthew Pickering's avatar
Matthew Pickering committed
124

125
   setEnvs tc_envs $ do {
126 127 128

   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations

129 130
   -- (D1) Bring pattern synonyms into scope.
   --      Need to do this before (D2) because rnTopBindsLHS
131
   --      looks up those pattern synonyms (#9889)
Matthew Pickering's avatar
Matthew Pickering committed
132 133

   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
134 135

   -- (D2) Rename the left-hand sides of the value bindings.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
136
   --     This depends on everything from (B) being in scope.
137 138
   --     It uses the fixity env from (A) to bind fixities for view patterns.
   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
139 140 141 142

   -- Bind the LHSes (and their fixities) in the global rdr environment
   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
                                                    -- They are already in scope
143
   traceRn "rnSrcDecls" (ppr id_bndrs) ;
144
   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
145
   setEnvs tc_envs $ do {
146 147 148 149 150 151 152 153 154 155 156 157 158

   --  Now everything is in scope, as the remaining renaming assumes.

   -- (E) Rename type and class decls
   --     (note that value LHSes need to be in scope for default methods)
   --
   -- You might think that we could build proper def/use information
   -- for type and class declarations, but they can be involved
   -- in mutual recursion across modules, and we only do the SCC
   -- analysis for them in the type checker.
   -- So we content ourselves with gathering uses only; that
   -- means we'll only report a declaration as unused if it isn't
   -- mentioned at all.  Ah well.
159
   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
160
   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
161 162

   -- (F) Rename Value declarations right-hand sides
163
   traceRn "Start rnmono" empty ;
164
   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
165 166 167 168 169 170 171
   is_boot <- tcIsHsBootOrSig ;
   (rn_val_decls, bind_dus) <- if is_boot
    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
    -- signatures), since val_bndr_set is empty (there are no x = ...
    -- bindings in an hs-boot.)
    then rnTopBindsBoot tc_bndrs new_lhs
    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
172
   traceRn "finish rnmono" (ppr rn_val_decls) ;
173 174

   -- (G) Rename Fixity and deprecations
175

176
   -- Rename fixity declarations and error if we try to
177
   -- fix something from another module (duplicates were checked in (A))
178
   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
179 180
   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
                        fix_decls ;
181 182

   -- Rename deprec decls;
183 184
   -- check for duplicates and ensure that deprecated things are defined locally
   -- at the moment, we don't keep these around past renaming
185
   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
186 187 188

   -- (H) Rename Everything else

189
   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
Alan Zimmerman's avatar
Alan Zimmerman committed
190
                                   rnList rnHsRuleDecls rule_decls ;
191
                           -- Inside RULES, scoped type variables are on
192 193 194 195 196
   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
197 198 199
      -- Haddock docs; no free vars
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;

200
   last_tcg_env <- getGblEnv ;
201
   -- (I) Compute the results and return
202
   let {rn_group = HsGroup { hs_ext     = noExtField,
203
                             hs_valds   = rn_val_decls,
204
                             hs_splcds  = rn_splice_decls,
205
                             hs_tyclds  = rn_tycl_decls,
206
                             hs_derivds = rn_deriv_decls,
207 208 209 210 211 212 213
                             hs_fixds   = rn_fix_decls,
                             hs_warnds  = [], -- warns are returned in the tcg_env
                                             -- (see below) not in the HsGroup
                             hs_fords  = rn_foreign_decls,
                             hs_annds  = rn_ann_decls,
                             hs_defds  = rn_default_decls,
                             hs_ruleds = rn_rule_decls,
214
                             hs_docs   = rn_docs } ;
215

216
        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
217
        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
218 219
        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
                              src_fvs5, src_fvs6, src_fvs7] ;
220
                -- It is tiresome to gather the binders from type and class decls
221

Ryan Scott's avatar
Ryan Scott committed
222
        src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
223 224
                -- Instance decls may have occurrences of things bound in bind_dus
                -- so we must put other_fvs last
225

226
        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
227 228
                        in -- we return the deprecs in the env, not in the HsGroup above
                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
229
       } ;
230 231
   traceRn "finish rnSrc" (ppr rn_group) ;
   traceRn "finish Dus" (ppr src_dus ) ;
232
   return (final_tcg_env, rn_group)
233
                    }}}}
234
rnSrcDecls (XHsGroup nec) = noExtCon nec
235

236 237
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
238
-- but there doesn't seem anywhere very logical to put it.
239
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
240 241 242

rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList f xs = mapFvRn (wrapLocFstM f) xs
243

Austin Seipp's avatar
Austin Seipp committed
244 245 246
{-
*********************************************************
*                                                       *
247
        HsDoc stuff
Austin Seipp's avatar
Austin Seipp committed
248 249 250
*                                                       *
*********************************************************
-}
251

252
rnDocDecl :: DocDecl -> RnM DocDecl
253
rnDocDecl (DocCommentNext doc) = do
254 255
  rn_doc <- rnHsDoc doc
  return (DocCommentNext rn_doc)
256
rnDocDecl (DocCommentPrev doc) = do
257 258 259 260 261 262 263 264
  rn_doc <- rnHsDoc doc
  return (DocCommentPrev rn_doc)
rnDocDecl (DocCommentNamed str doc) = do
  rn_doc <- rnHsDoc doc
  return (DocCommentNamed str rn_doc)
rnDocDecl (DocGroup lev doc) = do
  rn_doc <- rnHsDoc doc
  return (DocGroup lev rn_doc)
265

Austin Seipp's avatar
Austin Seipp committed
266 267 268
{-
*********************************************************
*                                                       *
269
        Source-code deprecations declarations
Austin Seipp's avatar
Austin Seipp committed
270 271
*                                                       *
*********************************************************
272

273 274 275
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

276 277
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
Austin Seipp's avatar
Austin Seipp committed
278
-}
279

280
-- checks that the deprecations are defined locally, and that there are no duplicates
281
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
282
rnSrcWarnDecls _ []
283
  = return NoWarnings
284

Alan Zimmerman's avatar
Alan Zimmerman committed
285
rnSrcWarnDecls bndr_set decls'
286
  = do { -- check for duplicates
287
       ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups
288
                          in addErrAt loc (dupWarnDecl lrdr' rdr))
289 290 291
               warn_rdr_dups
       ; pairs_s <- mapM (addLocM rn_deprec) decls
       ; return (WarnSome ((concat pairs_s))) }
292
 where
293
   decls = concatMap (wd_warnings . unLoc) decls'
Alan Zimmerman's avatar
Alan Zimmerman committed
294

295
   sig_ctxt = TopSigCtxt bndr_set
296

297
   rn_deprec (Warning _ rdr_names txt)
298
       -- ensures that the names are defined locally
Alan Zimmerman's avatar
Alan Zimmerman committed
299 300
     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                rdr_names
301
          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
302
   rn_deprec (XWarnDecl nec) = noExtCon nec
303

304
   what = text "deprecation"
305

306 307
   warn_rdr_dups = findDupRdrNames
                   $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls
308

309
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
310 311 312 313 314
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))

-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
315

Ian Lynagh's avatar
Ian Lynagh committed
316
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
317
-- Located RdrName -> DeprecDecl RdrName -> SDoc
318
dupWarnDecl d rdr_name
319
  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
320
          text "also at " <+> ppr (getLoc d)]
321

Austin Seipp's avatar
Austin Seipp committed
322 323 324
{-
*********************************************************
*                                                      *
325
\subsection{Annotation declarations}
Austin Seipp's avatar
Austin Seipp committed
326 327 328
*                                                      *
*********************************************************
-}
329

330
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
331
rnAnnDecl ann@(HsAnnotation _ s provenance expr)
332 333
  = addErrCtxt (annCtxt ann) $
    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
334
       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
335
                              rnLExpr expr
336
       ; return (HsAnnotation noExtField s provenance' expr',
Alan Zimmerman's avatar
Alan Zimmerman committed
337
                 provenance_fvs `plusFV` expr_fvs) }
338
rnAnnDecl (XAnnDecl nec) = noExtCon nec
339

340 341
rnAnnProvenance :: AnnProvenance RdrName
                -> RnM (AnnProvenance Name, FreeVars)
342
rnAnnProvenance provenance = do
343
    provenance' <- traverse lookupTopBndrRn provenance
344 345
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))

Austin Seipp's avatar
Austin Seipp committed
346 347 348
{-
*********************************************************
*                                                      *
349
\subsection{Default declarations}
Austin Seipp's avatar
Austin Seipp committed
350 351 352
*                                                      *
*********************************************************
-}
353

354
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
355
rnDefaultDecl (DefaultDecl _ tys)
356
  = do { (tys', fvs) <- rnLHsTypes doc_str tys
357
       ; return (DefaultDecl noExtField tys', fvs) }
358
  where
dreixel's avatar
dreixel committed
359
    doc_str = DefaultDeclCtx
360
rnDefaultDecl (XDefaultDecl nec) = noExtCon nec
361

Austin Seipp's avatar
Austin Seipp committed
362 363 364
{-
*********************************************************
*                                                      *
365
\subsection{Foreign declarations}
Austin Seipp's avatar
Austin Seipp committed
366 367 368
*                                                      *
*********************************************************
-}
369

370
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
371
rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
372 373
  = do { topEnv :: HscEnv <- getTopEnv
       ; name' <- lookupLocatedTopBndrRn name
374
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
375

376
        -- Mark any PackageTarget style imports as coming from the current package
377 378
       ; let unitId = thisPackage $ hsc_dflags topEnv
             spec'      = patchForeignImport unitId spec
379

380
       ; return (ForeignImport { fd_i_ext = noExtField
381
                               , fd_name = name', fd_sig_ty = ty'
382
                               , fd_fi = spec' }, fvs) }
383

384
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
385
  = do { name' <- lookupLocatedOccRn name
386
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
387
       ; return (ForeignExport { fd_e_ext = noExtField
388
                               , fd_name = name', fd_sig_ty = ty'
389 390
                               , fd_fe = spec }
                , fvs `addOneFV` unLoc name') }
391 392 393
        -- NB: a foreign export is an *occurrence site* for name, so
        --     we add it to the free-variable list.  It might, for example,
        --     be imported from another module
394

395
rnHsForeignDecl (XForeignDecl nec) = noExtCon nec
396

397
-- | For Windows DLLs we need to know what packages imported symbols are from
398
--      to generate correct calls. Imported symbols are tagged with the current
399
--      package, so if they get inlined across a package boundary we'll still
400
--      know where they're from.
401
--
402 403 404
patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
patchForeignImport unitId (CImport cconv safety fs spec src)
        = CImport cconv safety fs (patchCImportSpec unitId spec) src
405

406 407
patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
patchCImportSpec unitId spec
408
 = case spec of
409
        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget
410
        _                       -> spec
411

412 413
patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
patchCCallTarget unitId callTarget =
414
  case callTarget of
415
  StaticTarget src label Nothing isFun
416
                              -> StaticTarget src label (Just unitId) isFun
417
  _                           -> callTarget
418

Austin Seipp's avatar
Austin Seipp committed
419 420 421
{-
*********************************************************
*                                                      *
422
\subsection{Instance declarations}
Austin Seipp's avatar
Austin Seipp committed
423 424 425
*                                                      *
*********************************************************
-}
426

427
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
428
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
429
  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi
430
       ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }
431

432
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
433
  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi
434
       ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }
435 436

rnSrcInstDecl (ClsInstD { cid_inst = cid })
437 438 439
  = do { traceRn "rnSrcIstDecl {" (ppr cid)
       ; (cid', fvs) <- rnClsInstDecl cid
       ; traceRn "rnSrcIstDecl end }" empty
440
       ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }
441

442
rnSrcInstDecl (XInstDecl nec) = noExtCon nec
443

444
-- | Warn about non-canonical typeclass instance declarations
445
--
446 447 448 449 450 451 452
-- A "non-canonical" instance definition can occur for instances of a
-- class which redundantly defines an operation its superclass
-- provides as well (c.f. `return`/`pure`). In such cases, a canonical
-- instance is one where the subclass inherits its method
-- implementation from its superclass instance (usually the subclass
-- has a default method implementation to that effect). Consequently,
-- a non-canonical instance occurs when this is not the case.
453
--
454 455
-- See also descriptions of 'checkCanonicalMonadInstances' and
-- 'checkCanonicalMonoidInstances'
456
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
457 458 459
checkCanonicalInstances cls poly_ty mbinds = do
    whenWOptM Opt_WarnNonCanonicalMonadInstances
        checkCanonicalMonadInstances
460

461 462
    whenWOptM Opt_WarnNonCanonicalMonoidInstances
        checkCanonicalMonoidInstances
463 464

  where
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479
    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
    -- declarations. Specifically, the following conditions are verified:
    --
    -- In 'Monad' instances declarations:
    --
    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
    --
    -- In 'Applicative' instance declarations:
    --
    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
    --
    checkCanonicalMonadInstances
      | cls == applicativeClassName  = do
480
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
481
              case mbind of
482 483
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
484
                      | name == pureAName, isAliasMG mg == Just returnMName
485 486
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
487 488

                      | name == thenAName, isAliasMG mg == Just thenMName
489 490
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
491 492 493 494

                  _ -> return ()

      | cls == monadClassName  = do
495
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
496
              case mbind of
497 498
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
499
                      | name == returnMName, isAliasMG mg /= Just pureAName
500 501
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
502 503

                      | name == thenMName, isAliasMG mg /= Just thenAName
504 505
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
506 507

                  _ -> return ()
508 509 510

      | otherwise = return ()

511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
    -- | Check whether Monoid(mappend) is defined in terms of
    -- Semigroup((<>)) (and not the other way round). Specifically,
    -- the following conditions are verified:
    --
    -- In 'Monoid' instances declarations:
    --
    --  * If 'mappend' is overridden it must be canonical
    --    (i.e. @mappend = (<>)@)
    --
    -- In 'Semigroup' instance declarations:
    --
    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
    --
    checkCanonicalMonoidInstances
      | cls == semigroupClassName  = do
526
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
527
              case mbind of
528 529
                  FunBind { fun_id      = (dL->L _ name)
                          , fun_matches = mg }
530
                      | name == sappendName, isAliasMG mg == Just mappendName
531 532
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
533 534 535 536

                  _ -> return ()

      | cls == monoidClassName  = do
537
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
538
              case mbind of
539 540
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
541
                      | name == mappendName, isAliasMG mg /= Just sappendName
542 543
                      -> addWarnNonCanonicalMethod2NoDefault
                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
544 545 546 547 548

                  _ -> return ()

      | otherwise = return ()

549 550
    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
    -- binding, and return @Just rhsName@ if this is the case
551
    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
552 553 554 555 556 557
    isAliasMG MG {mg_alts = (dL->L _
                             [dL->L _ (Match { m_pats = []
                                             , m_grhss = grhss })])}
        | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss
        , EmptyLocalBinds _ <- unLoc lbinds
        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)
558 559 560
    isAliasMG _ = Nothing

    -- got "lhs = rhs" but expected something different
561 562 563
    addWarnNonCanonicalMethod1 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
564 565 566 567 568 569 570 571 572
                         quotes (text (lhs ++ " = " ++ rhs)) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Move definition from" <+>
                         quotes (text rhs) <+>
                         text "to" <+> quotes (text lhs)
                       ]

    -- expected "lhs = rhs" but got something else
573 574 575
    addWarnNonCanonicalMethod2 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
576 577 578 579 580 581 582 583
                         quotes (text lhs) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Either remove definition for" <+>
                         quotes (text lhs) <+> text "or define as" <+>
                         quotes (text (lhs ++ " = " ++ rhs))
                       ]

584
    -- like above, but method has no default impl
585 586 587
    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
588 589 590 591 592 593 594
                         quotes (text lhs) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Define as" <+>
                         quotes (text (lhs ++ " = " ++ rhs))
                       ]

595
    -- stolen from TcInstDcls
596
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
597
    instDeclCtxt1 hs_inst_ty
598
      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
599 600

    inst_decl_ctxt :: SDoc -> SDoc
601
    inst_decl_ctxt doc = hang (text "in the instance declaration for")
602 603 604
                         2 (quotes doc <> text ".")


605
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
606 607
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                           , cid_sigs = uprags, cid_tyfam_insts = ats
608
                           , cid_overlap_mode = oflag
609
                           , cid_datafam_insts = adts })
610
  = do { (inst_ty', inst_fvs)
611
           <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty
612
       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
613 614 615 616 617 618 619 620 621
       ; cls <-
           case hsTyGetAppHead_maybe head_ty' of
             Just (dL->L _ cls) -> pure cls
             Nothing -> do
               -- The instance is malformed. We'd still like
               -- to make *some* progress (rather than failing outright), so
               -- we report an error and continue for as long as we can.
               -- Importantly, this error should be thrown before we reach the
               -- typechecker, lest we encounter different errors that are
622
               -- hopelessly confusing (such as the one in #16114).
623 624 625 626 627 628 629 630
               addErrAt (getLoc (hsSigType inst_ty)) $
                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))
                    2 (vcat [ text "Class instances must be of the form"
                            , nest 2 $ text "context => C ty_1 ... ty_n"
                            , text "where" <+> quotes (char 'C')
                              <+> text "is a class"
                            ])
               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
631 632 633 634 635 636

          -- Rename the bindings
          -- The typechecker (not the renamer) checks that all
          -- the bindings are for the right class
          -- (Slightly strangely) when scoped type variables are on, the
          -- forall-d tyvars scope over the method bindings too
637
       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
638

639
       ; checkCanonicalInstances cls inst_ty' mbinds'
640

641 642
       -- Rename the associated types, and type signatures
       -- Both need to have the instance type variables in scope
643
       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
644
       ; ((ats', adts'), more_fvs)
645
             <- extendTyVarEnvFVRn ktv_names $
646 647
                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
648
                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
649

650 651
       ; let all_fvs = meth_fvs `plusFV` more_fvs
                                `plusFV` inst_fvs
652
       ; return (ClsInstDecl { cid_ext = noExtField
653
                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
654
                             , cid_sigs = uprags', cid_tyfam_insts = ats'
655
                             , cid_overlap_mode = oflag
656
                             , cid_datafam_insts = adts' },
657
                 all_fvs) }
658 659 660 661 662
             -- We return the renamed associated data type declarations so
             -- that they can be entered into the list of type declarations
             -- for the binding group, but we also keep a copy in the instance.
             -- The latter is needed for well-formedness checks in the type
             -- checker (eg, to ensure that all ATs of the instance actually
663 664 665 666 667
             -- receive a declaration).
             -- NB: Even the copies in the instance declaration carry copies of
             --     the instance context after renaming.  This is a bit
             --     strange, but should not matter (and it would be more work
             --     to remove the context).
668
rnClsInstDecl (XClsInstDecl nec) = noExtCon nec
669

670
rnFamInstEqn :: HsDocContext
671
             -> AssocTyFamInfo
672
             -> [Located RdrName]    -- Kind variables from the equation's RHS
673 674 675
             -> FamInstEqn GhcPs rhs
             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
676
rnFamInstEqn doc atfi rhs_kvars
677
    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
678
                               , feqn_bndrs  = mb_bndrs
679 680 681
                               , feqn_pats   = pats
                               , feqn_fixity = fixity
                               , feqn_rhs    = payload }}) rn_payload
682 683 684 685 686
  = do { let mb_cls = case atfi of
                        NonAssocTyFamEqn     -> Nothing
                        AssocTyFamDeflt cls  -> Just cls
                        AssocTyFamInst cls _ -> Just cls
       ; tycon'   <- lookupFamInstName mb_cls tycon
My Nguyen's avatar
My Nguyen committed
687
       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
Gabor Greif's avatar
Gabor Greif committed
688
             -- Use the "...Dups" form because it's needed
689
             -- below to report unused binder on the LHS
690 691 692 693 694

         -- Implicitly bound variables, empty if we have an explicit 'forall' according
         -- to the "forall-or-nothing" rule.
       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups
                      | otherwise = []
695 696 697 698 699
       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars

       ; let bndrs = fromMaybe [] mb_bndrs
             bnd_vars = map hsLTyVarLocName bndrs
             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
700 701
             -- Make sure to filter out the kind variables that were explicitly
             -- bound in the type patterns.
702
       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
703

704 705
         -- all names not bound in an explict forall
       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
706

707
             -- All the free vars of the family patterns
708
             -- with a sensible binding location
709 710 711
       ; ((bndrs', pats', payload'), fvs)
              <- bindLocalNamesFV all_imp_var_names $
                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
712 713 714 715 716 717
                                   Nothing bndrs $ \bndrs' ->
                 -- Note: If we pass mb_cls instead of Nothing here,
                 --  bindLHsTyVarBndrs will use class variables for any names
                 --  the user meant to bring in scope here. This is an explicit
                 --  forall, so we want fresh names, not class variables.
                 --  Thus: always pass Nothing
My Nguyen's avatar
My Nguyen committed
718
                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
719
                    ; (payload', rhs_fvs) <- rn_payload doc payload
720

721 722
                       -- Report unused binders on the LHS
                       -- See Note [Unused type variables in family instances]
723
                    ; let groups :: [NonEmpty (Located RdrName)]
724
                          groups = equivClasses cmpLocated $
725
                                   pat_kity_vars_with_dups
726
                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
727
                                     [ tv | (tv :| (_:_)) <- groups ]
728 729 730 731 732 733
                          -- Add to the used variables
                          --  a) any variables that appear *more than once* on the LHS
                          --     e.g.   F a Int a = Bool
                          --  b) for associated instances, the variables
                          --     of the instance decl.  See
                          --     Note [Unused type variables in family instances]
734 735
                    ; let nms_used = extendNameSetList rhs_fvs $
                                        inst_tvs ++ nms_dups
736 737 738 739
                          inst_tvs = case atfi of
                                       NonAssocTyFamEqn          -> []
                                       AssocTyFamDeflt _         -> []
                                       AssocTyFamInst _ inst_tvs -> inst_tvs
740
                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
741
                    ; warnUnusedTypePatterns all_nms nms_used
742

743
                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
744

My Nguyen's avatar
My Nguyen committed
745 746
       ; let all_fvs  = fvs `addOneFV` unLoc tycon'
            -- type instance => use, hence addOneFV
747

My Nguyen's avatar
My Nguyen committed
748
       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
749
                      , hsib_body
750
                          = FamEqn { feqn_ext    = noExtField
751
                                   , feqn_tycon  = tycon'
752
                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
753 754 755
                                   , feqn_pats   = pats'
                                   , feqn_fixity = fixity
                                   , feqn_rhs    = payload' } },
756
                 all_fvs) }
757 758
rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec
rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
759

760
rnTyFamInstDecl :: AssocTyFamInfo
761 762
                -> TyFamInstDecl GhcPs
                -> RnM (TyFamInstDecl GhcRn, FreeVars)
763 764
rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })
  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn
765
       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
766

767 768 769 770 771 772 773 774 775 776 777 778 779 780
-- | Tracks whether we are renaming:
--
-- 1. A type family equation that is not associated
--    with a parent type class ('NonAssocTyFamEqn')
--
-- 2. An associated type family default delcaration ('AssocTyFamDeflt')
--
-- 3. An associated type family instance declaration ('AssocTyFamInst')
data AssocTyFamInfo
  = NonAssocTyFamEqn
  | AssocTyFamDeflt Name   -- Name of the parent class
  | AssocTyFamInst  Name   -- Name of the parent class
                    [Name] -- Names of the tyvars of the parent instance decl

781 782 783 784 785 786 787
-- | Tracks whether we are renaming an equation in a closed type family
-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
data ClosedTyFamInfo
  = NotClosedTyFam
  | ClosedTyFam (Located RdrName) Name
                -- The names (RdrName and Name) of the closed type family

788
rnTyFamInstEqn :: AssocTyFamInfo
789
               -> ClosedTyFamInfo
790 791
               -> TyFamInstEqn GhcPs
               -> RnM (TyFamInstEqn GhcRn, FreeVars)
792
rnTyFamInstEqn atfi ctf_info
793 794
    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
                                   , feqn_rhs   = rhs }})
795
  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
796 797
       ; (eqn'@(HsIB { hsib_body =
                       FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
798
           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
799 800 801 802 803 804 805
       ; case ctf_info of
           NotClosedTyFam -> pure ()
           ClosedTyFam fam_rdr_name fam_name ->
             checkTc (fam_name == tycon') $
             withHsDocContext (TyFamilyCtx fam_rdr_name) $
             wrongTyFamName fam_name tycon'
       ; pure (eqn', fvs) }
806 807
rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec
rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec
808

809 810 811 812
rnTyFamDefltDecl :: Name
                 -> TyFamDefltDecl GhcPs
                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)
rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
813

814
rnDataFamInstDecl :: AssocTyFamInfo
815 816
                  -> DataFamInstDecl GhcPs
                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
817 818 819
rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
                         FamEqn { feqn_tycon = tycon
                                , feqn_rhs   = rhs }})})
820
  = do { let rhs_kvs = extractDataDefnKindVars rhs
821
       ; (eqn', fvs) <-
822
           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
823
       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
824 825 826 827
rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))
  = noExtCon nec
rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))
  = noExtCon nec
828

Austin Seipp's avatar
Austin Seipp committed
829
-- Renaming of the associated types in instances.
830

831
-- Rename associated type family decl in class
832
rnATDecls :: Name      -- Class
833 834
          -> [LFamilyDecl GhcPs]
          -> RnM ([LFamilyDecl GhcRn], FreeVars)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
835 836
rnATDecls cls at_decls
  = rnList (rnFamDecl (Just cls)) at_decls
837

838 839
rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames
                  decl GhcPs ->               -- an instance. rnTyFamInstDecl
840
                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
841
              -> Name      -- Class
842
              -> [Name]
843 844
              -> [Located (decl GhcPs)]
              -> RnM ([Located (decl GhcRn)], FreeVars)
845
-- Used for data and type family defaults in a class decl
846
-- and the family instance declarations in an instance
847 848
--
-- NB: We allow duplicate associated-type decls;
849
--     See Note [Associated type instances] in TcInstDcls
850
rnATInstDecls rnFun cls tv_ns at_insts
851
  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts
852
    -- See Note [Renaming associated types]
853

854 855 856 857 858 859 860 861 862 863 864 865 866 867
{- Note [Wildcards in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Wild cards can be used in type/data family instance declarations to indicate
that the name of a type variable doesn't matter. Each wild card will be
replaced with a new unique type variable. For instance:

    type family F a b :: *
    type instance F Int _ = Int

is the same as

    type family F a b :: *
    type instance F Int b = Int

My Nguyen's avatar
My Nguyen committed
868 869 870 871 872 873 874
This is implemented as follows: Unnamed wildcards remain unchanged after
the renamer, and then given fresh meta-variables during typechecking, and
it is handled pretty much the same way as the ones in partial type signatures.
We however don't want to emit hole constraints on wildcards in family
instances, so we turn on PartialTypeSignatures and turn off warning flag to
let typechecker know this.
See related Note [Wildcards in visible kind application] in TcHsType.hs
875 876 877

Note [Unused type variables in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
878 879 880 881 882 883
When the flag -fwarn-unused-type-patterns is on, the compiler reports
warnings about unused type variables in type-family instances. A
tpye variable is considered used (i.e. cannot be turned into a wildcard)
when

 * it occurs on the RHS of the family instance
884 885 886 887 888
   e.g.   type instance F a b = a    -- a is used on the RHS

 * it occurs multiple times in the patterns on the LHS
   e.g.   type instance F a a = Int  -- a appears more than once on LHS

889 890 891 892 893 894 895 896
 * it is one of the instance-decl variables, for associated types
   e.g.   instance C (a,b) where
            type T (a,b) = a
   Here the type pattern in the type instance must be the same as that
   for the class instance, so
            type T (a,_) = a
   would be rejected.  So we should not complain about an unused variable b

897
As usual, the warnings are not reported for type variables with names
898 899 900 901 902
beginning with an underscore.

Extra-constraints wild cards are not supported in type/data family
instance declarations.

903
Relevant tickets: #3699, #10586, #10982 and #11451.
904

905 906
Note [Renaming associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
907
Check that the RHS of the decl mentions only type variables that are explicitly