RnSource.hs 100 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
{-# LANGUAGE CPP, ScopedTypeVariables #-}
8 9
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
10

11
module RnSource (
12
        rnSrcDecls, addTcgDUs, findSplice
13
    ) where
14

15
#include "HsVersions.h"
sof's avatar
sof committed
16

17 18
import GhcPrelude

19
import {-# SOURCE #-} RnExpr( rnLExpr )
spinda's avatar
spinda committed
20
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
21

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

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

65
import Control.Monad
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
66
import Control.Arrow ( first )
67 68 69
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
David Eichmann's avatar
David Eichmann committed
70
import Data.Maybe ( isNothing, fromMaybe )
Jan Stolarek's avatar
Jan Stolarek committed
71
import qualified Data.Set as Set ( difference, fromList, toList, null )
72

Ben Gamari's avatar
Ben Gamari committed
73
{- | @rnSourceDecl@ "renames" declarations.
74 75 76
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:

Ben Gamari's avatar
Ben Gamari committed
77 78 79 80 81 82 83 84 85 86 87 88
* 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
-}
89
rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
90
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91 92 93 94 95 96 97 98 99 100 101
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 })
102 103 104
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
105
   --     Also checks for duplicates.
106
   local_fix_env <- makeMiniFixityEnv fix_decls ;
107 108

   -- (B) Bring top level binders (and their fixities) into scope,
109 110 111 112 113 114 115 116 117
   --     *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
   --
118
   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
Adam Gundry's avatar
Adam Gundry committed
119

Matthew Pickering's avatar
Matthew Pickering committed
120

121
   setEnvs tc_envs $ do {
122 123 124

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

125 126 127
   -- (D1) Bring pattern synonyms into scope.
   --      Need to do this before (D2) because rnTopBindsLHS
   --      looks up those pattern synonyms (Trac #9889)
Matthew Pickering's avatar
Matthew Pickering committed
128 129

   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
130 131

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

   -- 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
139
   traceRn "rnSrcDecls" (ppr id_bndrs) ;
140
   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
141
   setEnvs tc_envs $ do {
142 143 144 145 146 147 148 149 150 151 152 153 154

   --  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.
155
   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
156
   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
157 158

   -- (F) Rename Value declarations right-hand sides
159
   traceRn "Start rnmono" empty ;
160
   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
161 162 163 164 165 166 167
   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 ;
168
   traceRn "finish rnmono" (ppr rn_val_decls) ;
169 170

   -- (G) Rename Fixity and deprecations
171

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

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

   -- (H) Rename Everything else

185
   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
Alan Zimmerman's avatar
Alan Zimmerman committed
186
                                   rnList rnHsRuleDecls rule_decls ;
187
                           -- Inside RULES, scoped type variables are on
188 189 190 191 192
   (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 ;
193 194 195
      -- Haddock docs; no free vars
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;

196
   last_tcg_env <- getGblEnv ;
197
   -- (I) Compute the results and return
198 199
   let {rn_group = HsGroup { hs_ext     = noExt,
                             hs_valds   = rn_val_decls,
200
                             hs_splcds  = rn_splice_decls,
201
                             hs_tyclds  = rn_tycl_decls,
202
                             hs_derivds = rn_deriv_decls,
203 204 205 206 207 208 209
                             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,
210
                             hs_docs   = rn_docs } ;
211

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

218 219 220
        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
                -- Instance decls may have occurrences of things bound in bind_dus
                -- so we must put other_fvs last
221

222
        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
223 224
                        in -- we return the deprecs in the env, not in the HsGroup above
                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
225
       } ;
226 227
   traceRn "finish rnSrc" (ppr rn_group) ;
   traceRn "finish Dus" (ppr src_dus ) ;
228
   return (final_tcg_env, rn_group)
Adam Gundry's avatar
Adam Gundry committed
229
                    }}}}
230
rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
231

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

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

Austin Seipp's avatar
Austin Seipp committed
240 241 242
{-
*********************************************************
*                                                       *
243
        HsDoc stuff
Austin Seipp's avatar
Austin Seipp committed
244 245 246
*                                                       *
*********************************************************
-}
247

248
rnDocDecl :: DocDecl -> RnM DocDecl
249
rnDocDecl (DocCommentNext doc) = do
250 251
  rn_doc <- rnHsDoc doc
  return (DocCommentNext rn_doc)
252
rnDocDecl (DocCommentPrev doc) = do
253 254 255 256 257 258 259 260
  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)
261

Austin Seipp's avatar
Austin Seipp committed
262 263 264
{-
*********************************************************
*                                                       *
265
        Source-code deprecations declarations
Austin Seipp's avatar
Austin Seipp committed
266 267
*                                                       *
*********************************************************
268

269 270 271
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

272 273
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
Austin Seipp's avatar
Austin Seipp committed
274
-}
275

276
-- checks that the deprecations are defined locally, and that there are no duplicates
277
rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
278
rnSrcWarnDecls _ []
279
  = return NoWarnings
280

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

291
   sig_ctxt = TopSigCtxt bndr_set
292

293
   rn_deprec (Warning _ rdr_names txt)
294
       -- ensures that the names are defined locally
Alan Zimmerman's avatar
Alan Zimmerman committed
295 296
     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                rdr_names
297
          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
298
   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
299

300
   what = text "deprecation"
301

302
   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns)
Alan Zimmerman's avatar
Alan Zimmerman committed
303
                                               decls
304

305
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
306 307 308 309 310
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
311

Ian Lynagh's avatar
Ian Lynagh committed
312
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
313
-- Located RdrName -> DeprecDecl RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
314
dupWarnDecl (L loc _) rdr_name
315 316
  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
          text "also at " <+> ppr loc]
317

Austin Seipp's avatar
Austin Seipp committed
318 319 320
{-
*********************************************************
*                                                      *
321
\subsection{Annotation declarations}
Austin Seipp's avatar
Austin Seipp committed
322 323 324
*                                                      *
*********************************************************
-}
325

326
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
327
rnAnnDecl ann@(HsAnnotation _ s provenance expr)
328 329
  = addErrCtxt (annCtxt ann) $
    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
330
       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
331
                              rnLExpr expr
332
       ; return (HsAnnotation noExt s provenance' expr',
Alan Zimmerman's avatar
Alan Zimmerman committed
333
                 provenance_fvs `plusFV` expr_fvs) }
334
rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
335

336 337
rnAnnProvenance :: AnnProvenance RdrName
                -> RnM (AnnProvenance Name, FreeVars)
338
rnAnnProvenance provenance = do
339
    provenance' <- traverse lookupTopBndrRn provenance
340 341
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))

Austin Seipp's avatar
Austin Seipp committed
342 343 344
{-
*********************************************************
*                                                      *
345
\subsection{Default declarations}
Austin Seipp's avatar
Austin Seipp committed
346 347 348
*                                                      *
*********************************************************
-}
349

350
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
351
rnDefaultDecl (DefaultDecl _ tys)
352
  = do { (tys', fvs) <- rnLHsTypes doc_str tys
353
       ; return (DefaultDecl noExt tys', fvs) }
354
  where
dreixel's avatar
dreixel committed
355
    doc_str = DefaultDeclCtx
356
rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
357

Austin Seipp's avatar
Austin Seipp committed
358 359 360
{-
*********************************************************
*                                                      *
361
\subsection{Foreign declarations}
Austin Seipp's avatar
Austin Seipp committed
362 363 364
*                                                      *
*********************************************************
-}
365

366
rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
367
rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
368 369
  = do { topEnv :: HscEnv <- getTopEnv
       ; name' <- lookupLocatedTopBndrRn name
370
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
371

372
        -- Mark any PackageTarget style imports as coming from the current package
373 374
       ; let unitId = thisPackage $ hsc_dflags topEnv
             spec'      = patchForeignImport unitId spec
375

376 377
       ; return (ForeignImport { fd_i_ext = noExt
                               , fd_name = name', fd_sig_ty = ty'
378
                               , fd_fi = spec' }, fvs) }
379

380
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
381
  = do { name' <- lookupLocatedOccRn name
382
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
383 384
       ; return (ForeignExport { fd_e_ext = noExt
                               , fd_name = name', fd_sig_ty = ty'
385 386
                               , fd_fe = spec }
                , fvs `addOneFV` unLoc name') }
387 388 389
        -- 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
390

391 392
rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"

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

402 403
patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
patchCImportSpec unitId spec
404
 = case spec of
405
        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget
406
        _                       -> spec
407

408 409
patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
patchCCallTarget unitId callTarget =
410
  case callTarget of
411
  StaticTarget src label Nothing isFun
412
                              -> StaticTarget src label (Just unitId) isFun
413
  _                           -> callTarget
414

Austin Seipp's avatar
Austin Seipp committed
415 416 417
{-
*********************************************************
*                                                      *
418
\subsection{Instance declarations}
Austin Seipp's avatar
Austin Seipp committed
419 420 421
*                                                      *
*********************************************************
-}
422

423
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
424
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
425
  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
426
       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
427

428
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
429
  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
430
       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
431 432

rnSrcInstDecl (ClsInstD { cid_inst = cid })
433 434 435
  = do { traceRn "rnSrcIstDecl {" (ppr cid)
       ; (cid', fvs) <- rnClsInstDecl cid
       ; traceRn "rnSrcIstDecl end }" empty
436 437 438
       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }

rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
439

440
-- | Warn about non-canonical typeclass instance declarations
441
--
442 443 444 445 446 447 448
-- 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.
449
--
450 451
-- See also descriptions of 'checkCanonicalMonadInstances' and
-- 'checkCanonicalMonoidInstances'
452
checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
453 454 455
checkCanonicalInstances cls poly_ty mbinds = do
    whenWOptM Opt_WarnNonCanonicalMonadInstances
        checkCanonicalMonadInstances
456

457 458 459
    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
        checkCanonicalMonadFailInstances

460 461
    whenWOptM Opt_WarnNonCanonicalMonoidInstances
        checkCanonicalMonoidInstances
462 463

  where
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
    -- | 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
          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
              case mbind of
                  FunBind { fun_id = L _ name, fun_matches = mg }
                      | name == pureAName, isAliasMG mg == Just returnMName
483 484
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
485 486

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

                  _ -> return ()

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

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

                  _ -> return ()

      | otherwise = return ()

508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526
    -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
    -- declarations. Specifically, the following conditions are verified:
    --
    -- In 'Monad' instances declarations:
    --
    --  * If 'fail' is overridden it must be canonical
    --    (i.e. @fail = Control.Monad.Fail.fail@)
    --
    -- In 'MonadFail' instance declarations:
    --
    --  * Warn if 'fail' is defined backwards
    --    (i.e. @fail = Control.Monad.fail@).
    --
    checkCanonicalMonadFailInstances
      | cls == monadFailClassName  = do
          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
              case mbind of
                  FunBind { fun_id = L _ name, fun_matches = mg }
                      | name == failMName, isAliasMG mg == Just failMName_preMFP
527 528 529
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadFailInstances "fail"
                            "Control.Monad.fail"
530 531 532 533 534 535 536 537

                  _ -> return ()

      | cls == monadClassName  = do
          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
              case mbind of
                  FunBind { fun_id = L _ name, fun_matches = mg }
                      | name == failMName_preMFP, isAliasMG mg /= Just failMName
538 539 540
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadFailInstances "fail"
                            "Control.Monad.Fail.fail"
541 542 543 544
                  _ -> return ()

      | otherwise = return ()

545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
    -- | 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
          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
              case mbind of
                  FunBind { fun_id = L _ name, fun_matches = mg }
                      | name == sappendName, isAliasMG mg == Just mappendName
564 565
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
566 567 568 569 570 571 572 573

                  _ -> return ()

      | cls == monoidClassName  = do
          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
              case mbind of
                  FunBind { fun_id = L _ name, fun_matches = mg }
                      | name == mappendName, isAliasMG mg /= Just sappendName
574 575
                      -> addWarnNonCanonicalMethod2NoDefault
                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
576 577 578 579 580

                  _ -> return ()

      | otherwise = return ()

581 582
    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
    -- binding, and return @Just rhsName@ if this is the case
583
    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
584
    isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
585
        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
586
        , L _ (EmptyLocalBinds _) <- lbinds
587
        , L _ (HsVar _ (L _ rhsName)) <- body  = Just rhsName
588 589 590
    isAliasMG _ = Nothing

    -- got "lhs = rhs" but expected something different
591 592 593
    addWarnNonCanonicalMethod1 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
594 595 596 597 598 599 600 601 602
                         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
603 604 605
    addWarnNonCanonicalMethod2 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
606 607 608 609 610 611 612 613
                         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))
                       ]

614
    -- like above, but method has no default impl
615 616 617
    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
618 619 620 621 622 623 624
                         quotes (text lhs) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Define as" <+>
                         quotes (text (lhs ++ " = " ++ rhs))
                       ]

625
    -- stolen from TcInstDcls
626
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
627
    instDeclCtxt1 hs_inst_ty
628
      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
629 630

    inst_decl_ctxt :: SDoc -> SDoc
631
    inst_decl_ctxt doc = hang (text "in the instance declaration for")
632 633 634
                         2 (quotes doc <> text ".")


635
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
636 637
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                           , cid_sigs = uprags, cid_tyfam_insts = ats
638
                           , cid_overlap_mode = oflag
639
                           , cid_datafam_insts = adts })
640 641
  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
642
       ; let cls = case hsTyGetAppHead_maybe head_ty' of
643 644 645
                     Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
                     Just (L _ cls, _) -> cls
                     -- rnLHsInstType has added an error message
646
                     -- if hsTyGetAppHead_maybe fails
647 648 649 650 651 652

          -- 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
653
       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
654

655
       ; checkCanonicalInstances cls inst_ty' mbinds'
656

657 658
       -- Rename the associated types, and type signatures
       -- Both need to have the instance type variables in scope
659
       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
660
       ; ((ats', adts'), more_fvs)
661
             <- extendTyVarEnvFVRn ktv_names $
662 663
                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
664
                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
665

666 667
       ; let all_fvs = meth_fvs `plusFV` more_fvs
                                `plusFV` inst_fvs
668 669
       ; return (ClsInstDecl { cid_ext = noExt
                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
670
                             , cid_sigs = uprags', cid_tyfam_insts = ats'
671
                             , cid_overlap_mode = oflag
672
                             , cid_datafam_insts = adts' },
673
                 all_fvs) }
674 675 676 677 678
             -- 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
679 680 681 682 683
             -- 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).
684
rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
685

686 687 688 689 690
rnFamInstEqn :: HsDocContext
             -> Maybe (Name, [Name]) -- Nothing => not associated
                                     -- Just (cls,tvs) => associated,
                                     --   and gives class and tyvars of the
                                     --   parent instance delc
691
             -> [Located RdrName]    -- Kind variables from the equation's RHS
692 693 694
             -> FamInstEqn GhcPs rhs
             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
695 696
rnFamInstEqn doc mb_cls rhs_kvars
    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
697
                               , feqn_bndrs  = mb_bndrs
698 699 700
                               , feqn_pats   = pats
                               , feqn_fixity = fixity
                               , feqn_rhs    = payload }}) rn_payload
701
  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
702
       ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
Gabor Greif's avatar
Gabor Greif committed
703
             -- Use the "...Dups" form because it's needed
704
             -- below to report unsed binder on the LHS
705 706 707 708 709 710 711 712 713 714 715 716 717 718
       ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups

         -- all pat vars not explicitly bound (see extractHsTvBndrs)
       ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars
             imp_vars = case mb_imp_kity_vars of
                          -- kind vars are the only ones free if we have an explicit forall
                          Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars
                          -- all pattern vars are free otherwise
                          Nothing             -> freeKiTyVarsAllVars pat_kity_vars
       ; 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
719 720
             -- Make sure to filter out the kind variables that were explicitly
             -- bound in the type patterns.
721
       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
722

723 724
         -- all names not bound in an explict forall
       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
725

726
             -- All the free vars of the family patterns
727
             -- with a sensible binding location
728 729 730 731
       ; ((bndrs', pats', payload'), fvs)
              <- bindLocalNamesFV all_imp_var_names $
                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
                                   mb_cls bndrs $ \bndrs' ->
732
                 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
733
                    ; (payload', rhs_fvs) <- rn_payload doc payload
734

735 736
                       -- Report unused binders on the LHS
                       -- See Note [Unused type variables in family instances]
737
                    ; let groups :: [NonEmpty (Located RdrName)]
738 739
                          groups = equivClasses cmpLocated $
                                   freeKiTyVarsAllVars pat_kity_vars_with_dups
740
                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
741
                                     [ tv | (tv :| (_:_)) <- groups ]
742 743 744 745 746 747
                          -- 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]
748 749
                    ; let nms_used = extendNameSetList rhs_fvs $
                                        inst_tvs ++ nms_dups
750 751 752
                          inst_tvs = case mb_cls of
                                       Nothing            -> []
                                       Just (_, inst_tvs) -> inst_tvs
753 754 755
                          all_nms = all_imp_var_names
                                      ++ map hsLTyVarName bndrs'
                    ; warnUnusedTypePatterns all_nms nms_used
756

757
                         -- See Note [Renaming associated types]
758 759 760
                    ; let bad_tvs = maybe [] (filter is_bad . snd) mb_cls
                          var_name_set = mkNameSet (map hsLTyVarName bndrs'
                                                    ++ all_imp_var_names)
761
                          is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
762
                                           && not (cls_tkv `elemNameSet` var_name_set)
763
                    ; unless (null bad_tvs) (badAssocRhs bad_tvs)
764

765
                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
766

767
       ; let anon_wcs = concatMap collectAnonWildCards pats'
768
             all_ibs  = anon_wcs ++ all_imp_var_names
769 770 771 772 773
                        -- all_ibs: include anonymous wildcards in the implicit
                        -- binders In a type pattern they behave just like any
                        -- other type variable except for being anoymous.  See
                        -- Note [Wildcards in family instances]
             all_fvs  = fvs `addOneFV` unLoc tycon'
774
                        -- type instance => use, hence addOneFV
775

776
       ; return (HsIB { hsib_ext = all_ibs
777
                      , hsib_body
778 779
                          = FamEqn { feqn_ext    = noExt
                                   , feqn_tycon  = tycon'
780
                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
781 782 783
                                   , feqn_pats   = pats'
                                   , feqn_fixity = fixity
                                   , feqn_rhs    = payload' } },
784
                 all_fvs) }
785 786
rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
787 788

rnTyFamInstDecl :: Maybe (Name, [Name])
789 790
                -> TyFamInstDecl GhcPs
                -> RnM (TyFamInstDecl GhcRn, FreeVars)
791
rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
792
  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
793
       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
794 795

rnTyFamInstEqn :: Maybe (Name, [Name])
796 797
               -> TyFamInstEqn GhcPs
               -> RnM (TyFamInstEqn GhcRn, FreeVars)
798 799
rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
                                                     , feqn_rhs   = rhs }})
800
  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
801
       ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
802 803
rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
804 805

rnTyFamDefltEqn :: Name
806 807
                -> TyFamDefltEqn GhcPs
                -> RnM (TyFamDefltEqn GhcRn, FreeVars)
808
rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
809
                            , feqn_bndrs  = bndrs
810 811 812
                            , feqn_pats   = tyvars
                            , feqn_fixity = fixity
                            , feqn_rhs    = rhs })
813
  = do { let kvs = extractHsTyRdrTyVarsKindVars rhs
814
       ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
815 816
    do { tycon'      <- lookupFamInstName (Just cls) tycon
       ; (rhs', fvs) <- rnLHsType ctx rhs
817 818
       ; return (FamEqn { feqn_ext    = noExt
                        , feqn_tycon  = tycon'
819 820
                        , feqn_bndrs  = ASSERT( isNothing bndrs )
                                        Nothing
821 822
                        , feqn_pats   = tyvars'
                        , feqn_fixity = fixity
823
                        , feqn_rhs    = rhs' }, fvs) } }
824 825
  where
    ctx = TyFamilyCtx tycon
826
rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
827 828

rnDataFamInstDecl :: Maybe (Name, [Name])
829 830
                  -> DataFamInstDecl GhcPs
                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
831
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =