RnSource.hs 92.1 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, ScopedTypeVariables #-}

9
module RnSource (
10
        rnSrcDecls, addTcgDUs, findSplice
11
    ) where
12

13
#include "HsVersions.h"
sof's avatar
sof committed
14

15
import {-# SOURCE #-} RnExpr( rnLExpr )
spinda's avatar
spinda committed
16
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
17

18
import HsSyn
Matthew Pickering's avatar
Matthew Pickering committed
19
import FieldLabel
20
import RdrName
21
import RnTypes
22
import RnBinds
23
import RnEnv
24
import RnNames
25
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
26
import TcAnnotations    ( annCtxt )
27
import TcRnMonad
28

29
import ForeignCall      ( CCallTarget(..) )
30
import Module
31 32
import HscTypes         ( Warnings(..), plusWarns )
import Class            ( FunDep )
33
import PrelNames        ( applicativeClassName, pureAName, thenAName
34
                        , monadClassName, returnMName, thenMName
35
                        , monadFailClassName, failMName, failMName_preMFP
36 37 38
                        , semigroupClassName, sappendName
                        , monoidClassName, mappendName
                        )
39
import Name
40
import NameSet
41
import NameEnv
42
import Avail
43
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
44
import Bag
45
import BasicTypes       ( RuleName, pprRuleName )
46
import FastString
47
import SrcLoc
48
import DynFlags
49
import Util             ( debugIsOn, partitionWith )
50
import HscTypes         ( HscEnv, hsc_dflags )
51
import ListSetOps       ( findDupsEq, removeDups, equivClasses )
52
import Digraph          ( SCC, flattenSCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
niteria's avatar
niteria committed
53
import UniqFM
54
import qualified GHC.LanguageExtensions as LangExt
55

56
import Control.Monad
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
57
import Control.Arrow ( first )
58
import Data.List ( sortBy, mapAccumL )
Jan Stolarek's avatar
Jan Stolarek committed
59
import qualified Data.Set as Set ( difference, fromList, toList, null )
60

Austin Seipp's avatar
Austin Seipp committed
61
{-
62
@rnSourceDecl@ `renames' declarations.
63 64 65 66 67 68
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\item
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
69 70
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
71
\item
Gabor Greif's avatar
Gabor Greif committed
72
Checks that all variable occurrences are defined.
73
\item
74
Checks the @(..)@ etc constraints in the export list.
75
\end{enumerate}
Austin Seipp's avatar
Austin Seipp committed
76
-}
77

78
-- Brings the binders of the group into scope in the appropriate places;
79
-- does NOT assume that anything is in scope already
Simon Peyton Jones's avatar
Simon Peyton Jones committed
80
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
81
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
Simon Peyton Jones's avatar
Simon Peyton Jones committed
82 83 84 85 86 87 88 89 90 91 92 93
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_vects   = vect_decls,
                            hs_docs    = docs })
94 95 96
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
97
   --     Also checks for duplicates.
98
   local_fix_env <- makeMiniFixityEnv fix_decls ;
99 100

   -- (B) Bring top level binders (and their fixities) into scope,
101 102 103 104 105 106 107 108 109 110
   --     *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.
   --          Aso step (C) depends on datacons and record fields
   --
   --        * For hs-boot files, include the value signatures
   --          Again, they have no value declarations
   --
111
   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
Adam Gundry's avatar
Adam Gundry committed
112

Matthew Pickering's avatar
Matthew Pickering committed
113

114
   setEnvs tc_envs $ do {
115 116 117

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

118 119 120
   -- (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
121 122

   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
123 124

   -- (D2) Rename the left-hand sides of the value bindings.
125 126 127 128
   --     This depends on everything from (B) being in scope,
   --     and on (C) for resolving record wild cards.
   --     It uses the fixity env from (A) to bind fixities for view patterns.
   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
129 130 131 132 133

   -- 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
   traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
134
   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
Matthew Pickering's avatar
Matthew Pickering committed
135
   traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
136
   setEnvs tc_envs $ do {
137 138 139 140 141 142 143 144 145 146 147 148 149

   --  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.
150
   traceRn (text "Start rnTyClDecls" <+> ppr tycl_decls) ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
151
   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
152 153 154

   -- (F) Rename Value declarations right-hand sides
   traceRn (text "Start rnmono") ;
155
   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
156 157 158 159 160 161 162
   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 ;
163 164 165
   traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;

   -- (G) Rename Fixity and deprecations
166

167
   -- Rename fixity declarations and error if we try to
168
   -- fix something from another module (duplicates were checked in (A))
169
   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
170
   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
171 172

   -- Rename deprec decls;
173 174
   -- check for duplicates and ensure that deprecated things are defined locally
   -- at the moment, we don't keep these around past renaming
175
   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
176 177 178

   -- (H) Rename Everything else

179
   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
Alan Zimmerman's avatar
Alan Zimmerman committed
180
                                   rnList rnHsRuleDecls rule_decls ;
181
                           -- Inside RULES, scoped type variables are on
182 183 184 185 186 187
   (rn_vect_decls,    src_fvs3) <- rnList rnHsVectDecl    vect_decls ;
   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
   (rn_splice_decls,  src_fvs8) <- rnList rnSpliceDecl    splice_decls ;
188 189 190
      -- Haddock docs; no free vars
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;

191
   last_tcg_env <- getGblEnv ;
192
   -- (I) Compute the results and return
193
   let {rn_group = HsGroup { hs_valds   = rn_val_decls,
194
                             hs_splcds  = rn_splice_decls,
195
                             hs_tyclds  = rn_tycl_decls,
196
                             hs_derivds = rn_deriv_decls,
197 198 199 200 201 202 203 204
                             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,
                             hs_vects  = rn_vect_decls,
205
                             hs_docs   = rn_docs } ;
206

207
        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
208
        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
209 210
        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
                              src_fvs6, src_fvs7, src_fvs8] ;
211
                -- It is tiresome to gather the binders from type and class decls
212

213 214 215
        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
216

217
        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
218 219
                        in -- we return the deprecs in the env, not in the HsGroup above
                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
220
       } ;
Matthew Pickering's avatar
Matthew Pickering committed
221
   traceRn (text "last" <+> ppr (tcg_rdr_env final_tcg_env)) ;
222 223
   traceRn (text "finish rnSrc" <+> ppr rn_group) ;
   traceRn (text "finish Dus" <+> ppr src_dus ) ;
224
   return (final_tcg_env, rn_group)
Adam Gundry's avatar
Adam Gundry committed
225
                    }}}}
226

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

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

Austin Seipp's avatar
Austin Seipp committed
235 236 237
{-
*********************************************************
*                                                       *
238
        HsDoc stuff
Austin Seipp's avatar
Austin Seipp committed
239 240 241
*                                                       *
*********************************************************
-}
242

243
rnDocDecl :: DocDecl -> RnM DocDecl
244
rnDocDecl (DocCommentNext doc) = do
245 246
  rn_doc <- rnHsDoc doc
  return (DocCommentNext rn_doc)
247
rnDocDecl (DocCommentPrev doc) = do
248 249 250 251 252 253 254 255
  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)
256

Austin Seipp's avatar
Austin Seipp committed
257 258 259
{-
*********************************************************
*                                                       *
260
        Source-code fixity declarations
Austin Seipp's avatar
Austin Seipp committed
261 262 263
*                                                       *
*********************************************************
-}
264

265
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
266 267 268
-- Rename the fixity decls, so we can put
-- the renamed decls in the renamed syntax tree
-- Errors if the thing being fixed is not defined locally.
269 270 271
--
-- The returned FixitySigs are not actually used for anything,
-- except perhaps the GHCi API
272
rnSrcFixityDecls bndr_set fix_decls
273 274 275
  = do fix_decls <- mapM rn_decl fix_decls
       return (concat fix_decls)
  where
276
    sig_ctxt = TopSigCtxt bndr_set
277

278
    rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
279 280 281 282
        -- GHC extension: look up both the tycon and data con
        -- for con-like things; hence returning a list
        -- If neither are in scope, report an error; otherwise
        -- return a fixity sig for each (slightly odd)
283 284 285 286 287 288 289
    rn_decl (L loc (FixitySig fnames fixity))
      = do names <- mapM lookup_one fnames
           return [ L loc (FixitySig name fixity)
                  | name <- names ]

    lookup_one :: Located RdrName -> RnM [Located Name]
    lookup_one (L name_loc rdr_name)
290
      = setSrcSpan name_loc $
291
                    -- this lookup will fail if the definition isn't local
292
        do names <- lookupLocalTcNames sig_ctxt what rdr_name
293
           return [ L name_loc name | (_, name) <- names ]
294
    what = text "fixity signature"
295

Austin Seipp's avatar
Austin Seipp committed
296 297 298
{-
*********************************************************
*                                                       *
299
        Source-code deprecations declarations
Austin Seipp's avatar
Austin Seipp committed
300 301
*                                                       *
*********************************************************
302

303 304 305
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

306 307
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.
Austin Seipp's avatar
Austin Seipp committed
308
-}
309

310
-- checks that the deprecations are defined locally, and that there are no duplicates
Alan Zimmerman's avatar
Alan Zimmerman committed
311
rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
312
rnSrcWarnDecls _ []
313
  = return NoWarnings
314

Alan Zimmerman's avatar
Alan Zimmerman committed
315
rnSrcWarnDecls bndr_set decls'
316
  = do { -- check for duplicates
317
       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
318
                          in addErrAt loc (dupWarnDecl lrdr' rdr))
319 320 321
               warn_rdr_dups
       ; pairs_s <- mapM (addLocM rn_deprec) decls
       ; return (WarnSome ((concat pairs_s))) }
322
 where
Alan Zimmerman's avatar
Alan Zimmerman committed
323 324
   decls = concatMap (\(L _ d) -> wd_warnings d) decls'

325
   sig_ctxt = TopSigCtxt bndr_set
326

Alan Zimmerman's avatar
Alan Zimmerman committed
327
   rn_deprec (Warning rdr_names txt)
328
       -- ensures that the names are defined locally
Alan Zimmerman's avatar
Alan Zimmerman committed
329 330
     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                rdr_names
331
          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
332

333
   what = text "deprecation"
334

Alan Zimmerman's avatar
Alan Zimmerman committed
335 336
   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
                                               decls
337 338 339 340 341 342 343

findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
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
344

Ian Lynagh's avatar
Ian Lynagh committed
345
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
346
-- Located RdrName -> DeprecDecl RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
347
dupWarnDecl (L loc _) rdr_name
348 349
  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
          text "also at " <+> ppr loc]
350

Austin Seipp's avatar
Austin Seipp committed
351 352 353
{-
*********************************************************
*                                                      *
354
\subsection{Annotation declarations}
Austin Seipp's avatar
Austin Seipp committed
355 356 357
*                                                      *
*********************************************************
-}
358 359

rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
Alan Zimmerman's avatar
Alan Zimmerman committed
360
rnAnnDecl ann@(HsAnnotation s provenance expr)
361 362
  = addErrCtxt (annCtxt ann) $
    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
363
       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
364
                              rnLExpr expr
Alan Zimmerman's avatar
Alan Zimmerman committed
365 366
       ; return (HsAnnotation s provenance' expr',
                 provenance_fvs `plusFV` expr_fvs) }
367 368 369

rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
370
    provenance' <- traverse lookupTopBndrRn provenance
371 372
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))

Austin Seipp's avatar
Austin Seipp committed
373 374 375
{-
*********************************************************
*                                                      *
376
\subsection{Default declarations}
Austin Seipp's avatar
Austin Seipp committed
377 378 379
*                                                      *
*********************************************************
-}
380

Ian Lynagh's avatar
Ian Lynagh committed
381
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
382
rnDefaultDecl (DefaultDecl tys)
383
  = do { (tys', fvs) <- rnLHsTypes doc_str tys
384
       ; return (DefaultDecl tys', fvs) }
385
  where
dreixel's avatar
dreixel committed
386
    doc_str = DefaultDeclCtx
387

Austin Seipp's avatar
Austin Seipp committed
388 389 390
{-
*********************************************************
*                                                      *
391
\subsection{Foreign declarations}
Austin Seipp's avatar
Austin Seipp committed
392 393 394
*                                                      *
*********************************************************
-}
395

Ian Lynagh's avatar
Ian Lynagh committed
396
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
397
rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
398 399
  = do { topEnv :: HscEnv <- getTopEnv
       ; name' <- lookupLocatedTopBndrRn name
400
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
401

402
        -- Mark any PackageTarget style imports as coming from the current package
403 404
       ; let unitId = thisPackage $ hsc_dflags topEnv
             spec'      = patchForeignImport unitId spec
405

406 407 408
       ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
                               , fd_co = noForeignImportCoercionYet
                               , fd_fi = spec' }, fvs) }
409

410
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
411
  = do { name' <- lookupLocatedOccRn name
412 413 414 415 416
       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
       ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
                               , fd_co = noForeignExportCoercionYet
                               , fd_fe = spec }
                , fvs `addOneFV` unLoc name') }
417 418 419
        -- 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
420

421
-- | For Windows DLLs we need to know what packages imported symbols are from
422 423 424
--      to generate correct calls. Imported symbols are tagged with the current
--      package, so if they get inlined across a package boundry we'll still
--      know where they're from.
425
--
426 427 428
patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
patchForeignImport unitId (CImport cconv safety fs spec src)
        = CImport cconv safety fs (patchCImportSpec unitId spec) src
429

430 431
patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
patchCImportSpec unitId spec
432
 = case spec of
433
        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget
434
        _                       -> spec
435

436 437
patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
patchCCallTarget unitId callTarget =
438
  case callTarget of
439
  StaticTarget src label Nothing isFun
440
                              -> StaticTarget src label (Just unitId) isFun
441
  _                           -> callTarget
442

Austin Seipp's avatar
Austin Seipp committed
443 444 445
{-
*********************************************************
*                                                      *
446
\subsection{Instance declarations}
Austin Seipp's avatar
Austin Seipp committed
447 448 449
*                                                      *
*********************************************************
-}
450

Ian Lynagh's avatar
Ian Lynagh committed
451
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
452
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
453 454 455
  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
       ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }

456
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
457 458 459 460 461 462 463
  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
       ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }

rnSrcInstDecl (ClsInstD { cid_inst = cid })
  = do { (cid', fvs) <- rnClsInstDecl cid
       ; return (ClsInstD { cid_inst = cid' }, fvs) }

464
-- | Warn about non-canonical typeclass instance declarations
465
--
466 467 468 469 470 471 472
-- 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.
473
--
474 475 476 477 478 479
-- See also descriptions of 'checkCanonicalMonadInstances' and
-- 'checkCanonicalMonoidInstances'
checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
checkCanonicalInstances cls poly_ty mbinds = do
    whenWOptM Opt_WarnNonCanonicalMonadInstances
        checkCanonicalMonadInstances
480

481 482 483
    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
        checkCanonicalMonadFailInstances

484 485
    whenWOptM Opt_WarnNonCanonicalMonoidInstances
        checkCanonicalMonoidInstances
486 487

  where
488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506
    -- | 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
507 508
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
509 510

                      | name == thenAName, isAliasMG mg == Just thenMName
511 512
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
513 514 515 516 517 518 519 520

                  _ -> 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
521 522
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
523 524

                      | name == thenMName, isAliasMG mg /= Just thenAName
525 526
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
527 528 529 530 531

                  _ -> return ()

      | otherwise = return ()

532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550
    -- | 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
551 552 553
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonadFailInstances "fail"
                            "Control.Monad.fail"
554 555 556 557 558 559 560 561

                  _ -> 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
562 563 564
                      -> addWarnNonCanonicalMethod2
                            Opt_WarnNonCanonicalMonadFailInstances "fail"
                            "Control.Monad.Fail.fail"
565 566 567 568
                  _ -> return ()

      | otherwise = return ()

569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587
    -- | 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
588 589
                      -> addWarnNonCanonicalMethod1
                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
590 591 592 593 594 595 596 597

                  _ -> 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
598 599
                      -> addWarnNonCanonicalMethod2NoDefault
                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
600 601 602 603 604

                  _ -> return ()

      | otherwise = return ()

605 606 607 608 609 610 611 612 613 614
    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
    -- binding, and return @Just rhsName@ if this is the case
    isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name
    isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
        | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
        , L _ EmptyLocalBinds <- lbinds
        , L _ (HsVar (L _ rhsName)) <- body  = Just rhsName
    isAliasMG _ = Nothing

    -- got "lhs = rhs" but expected something different
615 616 617
    addWarnNonCanonicalMethod1 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
618 619 620 621 622 623 624 625 626
                         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
627 628 629
    addWarnNonCanonicalMethod2 flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
630 631 632 633 634 635 636 637
                         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))
                       ]

638
    -- like above, but method has no default impl
639 640 641
    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
        addWarn (Reason flag) $ vcat
                       [ text "Noncanonical" <+>
642 643 644 645 646 647 648
                         quotes (text lhs) <+>
                         text "definition detected"
                       , instDeclCtxt1 poly_ty
                       , text "Define as" <+>
                         quotes (text (lhs ++ " = " ++ rhs))
                       ]

649
    -- stolen from TcInstDcls
650
    instDeclCtxt1 :: LHsSigType Name -> SDoc
651
    instDeclCtxt1 hs_inst_ty
652
      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
653 654

    inst_decl_ctxt :: SDoc -> SDoc
655
    inst_decl_ctxt doc = hang (text "in the instance declaration for")
656 657 658
                         2 (quotes doc <> text ".")


659 660 661
rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
                           , cid_sigs = uprags, cid_tyfam_insts = ats
662
                           , cid_overlap_mode = oflag
663
                           , cid_datafam_insts = adts })
664 665
  = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
666
       ; let cls = case hsTyGetAppHead_maybe head_ty' of
667 668 669
                     Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
                     Just (L _ cls, _) -> cls
                     -- rnLHsInstType has added an error message
670
                     -- if hsTyGetAppHead_maybe fails
671 672 673 674 675 676

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

679
       ; checkCanonicalInstances cls inst_ty' mbinds'
680

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

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

708
rnFamInstDecl :: HsDocContext
709 710 711 712
              -> Maybe (Name, [Name])   -- Nothing => not associated
                                        -- Just (cls,tvs) => associated,
                                        --   and gives class and tyvars of the
                                        --   parent instance delc
713
              -> Located RdrName
714
              -> HsTyPats RdrName
715 716
              -> rhs
              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
717 718
              -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)
rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
719
  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
720 721 722 723
       ; let loc = case pats of
                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)
                     (L loc _ : []) -> loc
                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
724

725
       ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
Gabor Greif's avatar
Gabor Greif committed
726
             -- Use the "...Dups" form because it's needed
727
             -- below to report unsed binder on the LHS
728
       ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
729 730 731
                      freeKiTyVarsAllVars $
                      rmDupsInRdrTyVars pat_kity_vars_with_dups

732
             -- All the free vars of the family patterns
733
             -- with a sensible binding location
734
       ; ((pats', payload'), fvs)
735 736
              <- bindLocalNamesFV var_names $
                 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
737
                    ; (payload', rhs_fvs) <- rnPayload doc payload
738

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

759
                         -- See Note [Renaming associated types]
760
                    ; let bad_tvs = case mb_cls of
761 762
                                      Nothing           -> []
                                      Just (_,cls_tkvs) -> filter is_bad cls_tkvs
763
                          var_name_set = mkNameSet var_names
764 765

                          is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
766
                                        && not (cls_tkv `elemNameSet` var_name_set)
767
                    ; unless (null bad_tvs) (badAssocRhs bad_tvs)
768

769
                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
770

771 772 773 774 775 776 777 778
       ; let anon_wcs = concatMap collectAnonWildCards pats'
             all_ibs  = anon_wcs ++ var_names
                        -- 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'

779
       ; return (tycon',
780 781
                 HsIB { hsib_body = pats'
                      , hsib_vars = all_ibs },
782 783
                 payload',
                 all_fvs) }
784
             -- type instance => use, hence addOneFV
785 786 787 788

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

rnTyFamInstEqn :: Maybe (Name, [Name])
               -> TyFamInstEqn RdrName
               -> RnM (TyFamInstEqn Name, FreeVars)
797
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
798
                                , tfe_pats  = pats
799
                                , tfe_rhs   = rhs })
800 801
  = do { (tycon', pats', rhs', fvs) <-
           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
802 803 804 805 806 807 808 809 810 811
       ; return (TyFamEqn { tfe_tycon = tycon'
                          , tfe_pats  = pats'
                          , tfe_rhs   = rhs' }, fvs) }

rnTyFamDefltEqn :: Name
                -> TyFamDefltEqn RdrName
                -> RnM (TyFamDefltEqn Name, FreeVars)
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
                              , tfe_pats  = tyvars
                              , tfe_rhs   = rhs })
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
812
  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
813 814 815 816 817 818 819
    do { tycon'      <- lookupFamInstName (Just cls) tycon
       ; (rhs', fvs) <- rnLHsType ctx rhs
       ; return (TyFamEqn { tfe_tycon = tycon'
                          , tfe_pats  = tyvars'
                          , tfe_rhs   = rhs' }, fvs) }
  where
    ctx = TyFamilyCtx tycon