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 )
spinda's avatar
spinda committed
22
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
23

24
import HsSyn
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
                        , monadClassName, returnMName, thenMName
46
                        , monadFailClassName, failMName, failMName_preMFP
47 48 49
                        , semigroupClassName, sappendName
                        , monoidClassName, mappendName
                        )
50
import Name
51
import NameSet
52
import NameEnv
53
import Avail
54
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
55
import Bag
56
import BasicTypes       ( pprRuleName )
57
import FastString
58
import SrcLoc
59
import DynFlags
60
import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
61
import HscTypes         ( HscEnv, hsc_dflags )
62
import ListSetOps       ( findDupsEq, removeDups, equivClasses )
63
import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
niteria's avatar
niteria committed
64
                        , stronglyConnCompFromEdgedVerticesUniq )
David Feuer's avatar
David Feuer committed
65
import UniqSet
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(..) )
David Eichmann's avatar
David Eichmann committed
73
import Data.Maybe ( isNothing, fromMaybe )
Jan Stolarek's avatar
Jan Stolarek committed
74
import qualified Data.Set as Set ( difference, fromList, toList, null )
75

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

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

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

Matthew Pickering's avatar
Matthew Pickering committed
123

124
   setEnvs tc_envs $ do {
125 126 127

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

128 129 130
   -- (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
131 132

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

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

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

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

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

   -- (G) Rename Fixity and deprecations
174

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

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

   -- (H) Rename Everything else

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

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

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

221 222 223
        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
224

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

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

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

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

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

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

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

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

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

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

294
   sig_ctxt = TopSigCtxt bndr_set
295

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

303
   what = text "deprecation"
304

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

308
findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
309 310 311 312 313
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
314

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

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

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

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

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

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

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

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

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

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

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

394 395
rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"

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

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

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

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

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

431
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
432
  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
433
       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
434 435

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

rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
442

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

460 461 462
    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
        checkCanonicalMonadFailInstances

463 464
    whenWOptM Opt_WarnNonCanonicalMonoidInstances
        checkCanonicalMonoidInstances
465 466

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

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

                  _ -> return ()

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

                      | name == thenMName, isAliasMG mg /= Just thenAName
506 507
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
508 509 510 511 512

                  _ -> return ()

      | otherwise = return ()

513 514 515 516 517 518 519 520 521 522 523 524 525 526 527
    -- | 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
528
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
529
              case mbind of
530 531
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
532
                      | name == failMName, isAliasMG mg == Just failMName_preMFP
533 534 535
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadFailInstances "fail"
                            "Control.Monad.fail"
536 537 538 539

                  _ -> return ()

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

      | otherwise = return ()

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

                  _ -> return ()

      | cls == monoidClassName  = do
578
          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
579
              case mbind of
580 581
                  FunBind { fun_id = (dL->L _ name)
                          , fun_matches = mg }
582
                      | name == mappendName, isAliasMG mg /= Just sappendName
583 584
                      -> addWarnNonCanonicalMethod2NoDefault
                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
585 586 587 588 589

                  _ -> return ()

      | otherwise = return ()

590 591
    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
    -- binding, and return @Just rhsName@ if this is the case
592
    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
593 594 595 596 597 598
    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)
599 600 601
    isAliasMG _ = Nothing

    -- got "lhs = rhs" but expected something different
602 603 604
    addWarnNonCanonicalMethod1 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
605 606 607 608 609 610 611 612 613
                         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
614 615 616
    addWarnNonCanonicalMethod2 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
617 618 619 620 621 622 623 624
                         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))
                       ]

625
    -- like above, but method has no default impl
626 627 628
    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
629 630 631 632 633 634 635
                         quotes (text lhs) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Define as" <+>
                         quotes (text (lhs ++ " = " ++ rhs))
                       ]

636
    -- stolen from TcInstDcls
637
    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
638
    instDeclCtxt1 hs_inst_ty
639
      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
640 641

    inst_decl_ctxt :: SDoc -> SDoc
642
    inst_decl_ctxt doc = hang (text "in the instance declaration for")
643 644 645
                         2 (quotes doc <> text ".")


646
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
647 648
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                           , cid_sigs = uprags, cid_tyfam_insts = ats
649
                           , cid_overlap_mode = oflag
650
                           , cid_datafam_insts = adts })
651 652
  = do { (inst_ty', inst_fvs)
           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
653
       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
       ; 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
               -- hopelessly confusing (such as the one in Trac #16114).
               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>"))
672 673 674 675 676 677

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

680
       ; checkCanonicalInstances cls inst_ty' mbinds'
681

682 683
       -- Rename the associated types, and type signatures
       -- Both need to have the instance type variables in scope
684
       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
685
       ; ((ats', adts'), more_fvs)
686
             <- extendTyVarEnvFVRn ktv_names $
687 688
                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
689
                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
690

691 692
       ; let all_fvs = meth_fvs `plusFV` more_fvs
                                `plusFV` inst_fvs
693 694
       ; return (ClsInstDecl { cid_ext = noExt
                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
695
                             , cid_sigs = uprags', cid_tyfam_insts = ats'
696
                             , cid_overlap_mode = oflag
697
                             , cid_datafam_insts = adts' },
698
                 all_fvs) }
699 700 701 702 703
             -- 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
704 705 706 707 708
             -- 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).
709
rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
710

711 712 713 714
rnFamInstEqn :: HsDocContext
             -> Maybe (Name, [Name]) -- Nothing => not associated
                                     -- Just (cls,tvs) => associated,
                                     --   and gives class and tyvars of the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
715
                                     --   parent instance decl
716
             -> [Located RdrName]    -- Kind variables from the equation's RHS
717 718 719
             -> FamInstEqn GhcPs rhs
             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
720 721
rnFamInstEqn doc mb_cls rhs_kvars
    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
722
                               , feqn_bndrs  = mb_bndrs
723 724 725
                               , feqn_pats   = pats
                               , feqn_fixity = fixity
                               , feqn_rhs    = payload }}) rn_payload
726
  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
My Nguyen's avatar
My Nguyen committed
727
       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
Gabor Greif's avatar
Gabor Greif committed
728
             -- Use the "...Dups" form because it's needed
729
             -- below to report unsed binder on the LHS
730 731 732 733 734

         -- 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 = []
735 736 737 738 739
       ; 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
740 741
             -- Make sure to filter out the kind variables that were explicitly
             -- bound in the type patterns.
742
       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
743

744 745
         -- all names not bound in an explict forall
       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
746

747
             -- All the free vars of the family patterns
748
             -- with a sensible binding location
749 750 751
       ; ((bndrs', pats', payload'), fvs)
              <- bindLocalNamesFV all_imp_var_names $
                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
752 753 754 755 756 757
                                   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
758
                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
759
                    ; (payload', rhs_fvs) <- rn_payload doc payload
760

761 762
                       -- Report unused binders on the LHS
                       -- See Note [Unused type variables in family instances]
763
                    ; let groups :: [NonEmpty (Located RdrName)]
764
                          groups = equivClasses cmpLocated $
765
                                   pat_kity_vars_with_dups
766
                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
767
                                     [ tv | (tv :| (_:_)) <- groups ]
768 769 770 771 772 773
                          -- 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]
mayac's avatar