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

5
\section[TcMovectle]{Typechecking a whole module}
6 7

https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
Austin Seipp's avatar
Austin Seipp committed
8
-}
9

10 11
{-# LANGUAGE CPP, NondecreasingIndentation #-}

12 13
module TcRnDriver (
#ifdef GHCI
dterei's avatar
dterei committed
14 15 16 17 18
        tcRnStmt, tcRnExpr, tcRnType,
        tcRnImportDecls,
        tcRnLookupRdrName,
        getModuleInterface,
        tcRnDeclsi,
dterei's avatar
dterei committed
19
        isGHCiMonad,
20
        runTcInteractive,    -- Used by GHC API clients (Trac #8878)
21
#endif
dterei's avatar
dterei committed
22 23
        tcRnLookupName,
        tcRnGetInfo,
24
        tcRnModule, tcRnModuleTcRnM,
Adam Gundry's avatar
Adam Gundry committed
25
        tcTopSrcDecls,
26 27
    ) where

28
#ifdef GHCI
29 30
import {-# SOURCE #-} TcSplice ( runQuasi )
import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
31 32 33 34 35 36 37 38 39 40 41
import IfaceEnv( externaliseName )
import TcType   ( isUnitTy, isTauTy )
import TcHsType
import TcMatches
import RnTypes
import RnExpr
import MkId
import TidyPgm    ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
42 43
#endif

44 45 46 47 48 49 50
import DynFlags
import StaticFlags
import HsSyn
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
51
import TcRnMonad
52
import TcEvidence
53 54
import PprTyThing( pprTyThing )
import Coercion( pprCoAxiom )
55
import FamInst
56 57
import InstEnv
import FamInstEnv
58
import TcAnnotations
59
import TcBinds
60
import HeaderInfo       ( mkPrelImports )
61 62 63 64 65 66
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
67
import TcMType
68 69 70 71
import MkIface
import TcSimplify
import TcTyClsDecls
import LoadIface
72
import TidyPgm    ( mkBootModDetailsTc )
73 74 75 76 77
import RnNames
import RnEnv
import RnSource
import ErrUtils
import Id
78
import IdInfo( IdDetails( VanillaId ) )
79
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
80
import Module
81
import UniqFM
82
import Name
83
import NameEnv
84
import NameSet
85
import Avail
86 87 88
import TyCon
import SrcLoc
import HscTypes
89
import ListSetOps
90
import Outputable
cactus's avatar
cactus committed
91
import ConLike
92 93 94
import DataCon
import Type
import Class
95
import BasicTypes hiding( SuccessFlag(..) )
96
import CoAxiom
97
import Annotations
98
import Data.List ( sortBy )
99
import Data.Ord
100
import FastString
101
import Maybes
102 103
import Util
import Bag
104

105
import Control.Monad
106

107
#include "HsVersions.h"
108

Austin Seipp's avatar
Austin Seipp committed
109 110 111
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
112
        Typecheck and rename a module
Austin Seipp's avatar
Austin Seipp committed
113 114 115
*                                                                      *
************************************************************************
-}
116

117
-- | Top level entry point for typechecker and renamer
dterei's avatar
dterei committed
118
tcRnModule :: HscEnv
dterei's avatar
dterei committed
119 120
           -> HscSource
           -> Bool              -- True <=> save renamed syntax
121
           -> HsParsedModule
dterei's avatar
dterei committed
122
           -> IO (Messages, Maybe TcGblEnv)
123

124
tcRnModule hsc_env hsc_src save_rn_syntax
125
   parsedModule@HsParsedModule {hpm_module=L loc this_module}
126
 | RealSrcSpan real_loc <- loc
127 128
 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;

129 130 131
      ; initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
               withTcPlugins hsc_env $
               tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
dterei's avatar
dterei committed
132

133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
  | otherwise
  = return ((emptyBag, unitBag err_msg), Nothing)

  where
    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
              text "Module does not have a RealSrcSpan:" <+> ppr this_mod

    this_pkg = thisPackage (hsc_dflags hsc_env)

    pair :: (Module, SrcSpan)
    pair@(this_mod,_)
      | Just (L mod_loc mod) <- hsmodName this_module
      = (mkModule this_pkg mod, mod_loc)

      | otherwise   -- 'module M where' is omitted
      = (mAIN, srcLocSpan (srcSpanStart loc))
dterei's avatar
dterei committed
149

150

151 152 153 154 155 156 157 158 159 160 161 162 163
-- To be called at the beginning of renaming hsig files.
-- If we're processing a signature, load up the RdrEnv
-- specified by sig-of so that
-- when we process top-level bindings, we pull in the right
-- original names.  We also need to add in dependencies from
-- the implementation (orphans, family instances, packages),
-- similar to how rnImportDecl handles things.
-- ToDo: Handle SafeHaskell
tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv
tcRnSignature dflags hsc_src
 = do { tcg_env <- getGblEnv ;
        case tcg_sig_of tcg_env of {
          Just sof
164 165 166 167 168 169
           | hsc_src /= HsBootFile -> do
                { modname <- fmap moduleName getModule
                ; addErr (text "Found -sig-of entry for" <+> ppr modname
                                <+> text "which is not hs-boot." $$
                          text "Try removing" <+> ppr modname <+>
                          text "from -sig-of")
170 171 172 173 174
                ; return tcg_env
                }
           | otherwise -> do
            { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof
            ; let { gr = mkGlobalRdrEnv
175
                              (gresFromAvails Nothing (mi_exports sig_iface))
176 177 178 179 180 181 182
                  ; avails = calculateAvails dflags
                                    sig_iface False{- safe -} False{- boot -} }
            ; return (tcg_env
                { tcg_impl_rdr_env = Just gr
                , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails
                })
            } ;
183
          Nothing -> return tcg_env
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
        }
      }

checkHsigIface :: HscEnv -> TcGblEnv -> TcRn ()
checkHsigIface hsc_env tcg_env
  = case tcg_impl_rdr_env tcg_env of
      Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env
                    ; checkHsigIface' gr sig_details
                    }
      Nothing -> return ()

checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn ()
checkHsigIface' gr
  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
               md_types = sig_type_env, md_exports = sig_exports}
  = do { traceTc "checkHsigIface" $ vcat
           [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
       ; mapM_ check_export sig_exports
       ; unless (null sig_fam_insts) $
           panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
                  "instances in hsig files yet...")
       ; mapM_ check_inst sig_insts
       ; failIfErrsM
       }
  where
    check_export sig_avail
      -- Skip instances, we'll check them later
      | name `elem` dfun_names = return ()
      | otherwise = do
        { -- Lookup local environment only (don't want to accidentally pick
          -- up the backing copy.)  We consult tcg_type_env because we want
          -- to pick up wired in names too (which get dropped by the iface
          -- creation process); it's OK for a signature file to mention
          -- a wired in name.
          env <- getGblEnv
        ; case lookupNameEnv (tcg_type_env env) name of
            Nothing
                -- All this means is no local definition is available: but we
                -- could have created the export this way:
                --
                -- module ASig(f) where
                --      import B(f)
                --
                -- In this case, we have to just lookup the identifier in
                -- the backing implementation and make sure it matches.
                | [GRE { gre_name = name' }]
                    <- lookupGlobalRdrEnv gr (nameOccName name)
                , name == name' -> return ()
                -- TODO: Possibly give a different error if the identifier
                -- is exported, but it's a different original name
                | otherwise -> addErrAt (nameSrcSpan name)
                                (missingBootThing False name "exported by")
            Just sig_thing -> do {
          -- We use tcLookupImported_maybe because we want to EXCLUDE
          -- tcg_env.
        ; r <- tcLookupImported_maybe name
        ; case r of
            Failed err -> addErr err
242
            Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
243 244 245 246 247 248 249 250
        }}
      where
        name          = availName sig_avail

    dfun_names = map getName sig_insts

    -- In general, for hsig files we can't assume that the implementing
    -- file actually implemented the instances (they may be reexported
Simon Peyton Jones's avatar
Simon Peyton Jones committed
251
    -- from elsewhere).  Where should we look for the instances?  We do
252 253 254 255 256 257 258 259 260 261
    -- the same as we would otherwise: consult the EPS.  This isn't
    -- perfect (we might conclude the module exports an instance
    -- when it doesn't, see #9422), but we will never refuse to compile
    -- something
    check_inst :: ClsInst -> TcM ()
    check_inst sig_inst
        = do eps <- getEps
             when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $
               addErrTc (instMisMatch False sig_inst)

262 263 264 265 266
tcRnModuleTcRnM :: HscEnv
                -> HscSource
                -> HsParsedModule
                -> (Module, SrcSpan)
                -> TcRn TcGblEnv
267
-- Factored out separately from tcRnModule so that a Core plugin can
268
-- call the type checker directly
269
tcRnModuleTcRnM hsc_env hsc_src
270 271 272 273 274 275 276 277 278
                (HsParsedModule {
                   hpm_module =
                      (L loc (HsModule maybe_mod export_ies
                                       import_decls local_decls mod_deprec
                                       maybe_doc_hdr)),
                   hpm_src_files = src_files
                })
                (this_mod, prel_imp_loc)
 = setSrcSpan loc $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
279 280
   do { let { dflags = hsc_dflags hsc_env
            ; explicit_mod_hdr = isJust maybe_mod } ;
281 282

        tcg_env <- tcRnSignature dflags hsc_src ;
Simon Peyton Jones's avatar
Simon Peyton Jones committed
283 284 285 286 287 288 289 290 291 292 293 294
        setGblEnv tcg_env $ do {

                -- Load the hi-boot interface for this module, if any
                -- We do this now so that the boot_names can be passed
                -- to tcTyAndClassDecls, because the boot_names are
                -- automatically considered to be loop breakers
                --
                -- Do this *after* tcRnImports, so that we know whether
                -- a module that we import imports us; and hence whether to
                -- look for a hi-boot file
        boot_info <- tcHiBootIface hsc_src this_mod ;
        setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do {
295 296

        -- Deal with imports; first add implicit prelude
297 298 299 300
        implicit_prelude <- xoptM Opt_ImplicitPrelude;
        let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
                                         implicit_prelude import_decls } ;

ian@well-typed.com's avatar
ian@well-typed.com committed
301
        whenWOptM Opt_WarnImplicitPrelude $
302 303
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;

dterei's avatar
dterei committed
304
        tcg_env <- {-# SCC "tcRnImports" #-}
305
                   tcRnImports hsc_env (prel_imports ++ import_decls) ;
306

Austin Seipp's avatar
Austin Seipp committed
307
          -- If the whole module is warned about or deprecated
308 309
          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
          -- a WarnAll, it will override any subseqent depracations added to tcg_warns
310 311 312
        let { tcg_env1 = case mod_deprec of
                         Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
                         Nothing        -> tcg_env
313
            } ;
314

315
        setGblEnv tcg_env1 $ do {
dterei's avatar
dterei committed
316 317 318

                -- Rename and type check the declarations
        traceRn (text "rn1a") ;
319
        tcg_env <- if isHsBoot hsc_src then
320
                        tcRnHsBootDecls hsc_src local_decls
dterei's avatar
dterei committed
321
                   else
dterei's avatar
dterei committed
322
                        {-# SCC "tcRnSrcDecls" #-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
323
                        tcRnSrcDecls explicit_mod_hdr export_ies local_decls ;
dterei's avatar
dterei committed
324 325 326
        setGblEnv tcg_env               $ do {

                -- Process the export list
327
        traceRn (text "rn4a: before exports");
Simon Peyton Jones's avatar
Simon Peyton Jones committed
328
        tcg_env <- rnExports explicit_mod_hdr export_ies tcg_env ;
dterei's avatar
dterei committed
329
        traceRn (text "rn4b: after exports") ;
330

331 332 333
                -- Check that main is exported (must be after rnExports)
        checkMainExported tcg_env ;

dterei's avatar
dterei committed
334 335
        -- Compare the hi-boot iface (if any) with the real thing
        -- Must be done after processing the exports
Simon Peyton Jones's avatar
Simon Peyton Jones committed
336
        tcg_env <- checkHiBootIface tcg_env boot_info ;
337

338 339 340 341 342 343 344 345 346 347 348 349 350 351 352
        -- Compare the hsig tcg_env with the real thing
        checkHsigIface hsc_env tcg_env ;

        -- Nub out type class instances now that we've checked them,
        -- if we're compiling an hsig with sig-of.
        -- See Note [Signature files and type class instances]
        tcg_env <- (case tcg_sig_of tcg_env of
            Just _ -> return tcg_env {
                        tcg_inst_env = emptyInstEnv,
                        tcg_fam_inst_env = emptyFamInstEnv,
                        tcg_insts = [],
                        tcg_fam_insts = []
                        }
            Nothing -> return tcg_env) ;

dterei's avatar
dterei committed
353
        -- The new type env is already available to stuff slurped from
dterei's avatar
dterei committed
354
        -- interface files, via TcEnv.updateGlobalTypeEnv
dterei's avatar
dterei committed
355 356
        -- It's important that this includes the stuff in checkHiBootIface,
        -- because the latter might add new bindings for boot_dfuns,
dterei's avatar
dterei committed
357
        -- which may be mentioned in imported unfoldings
358

dterei's avatar
dterei committed
359 360 361
                -- Don't need to rename the Haddock documentation,
                -- it's not parsed by GHC anymore.
        tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
362

dterei's avatar
dterei committed
363 364
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
365

366 367 368 369
                -- add extra source files to tcg_dependent_files
        addDependentFiles src_files ;

                -- Dump output and return
dterei's avatar
dterei committed
370 371
        tcDump tcg_env ;
        return tcg_env
Simon Peyton Jones's avatar
Simon Peyton Jones committed
372
    }}}}}
373 374 375 376

implicitPreludeWarn :: SDoc
implicitPreludeWarn
  = ptext (sLit "Module `Prelude' implicitly imported")
377

Austin Seipp's avatar
Austin Seipp committed
378 379 380
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
381
                Import declarations
Austin Seipp's avatar
Austin Seipp committed
382 383 384
*                                                                      *
************************************************************************
-}
385

386 387
tcRnImports :: HscEnv -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env import_decls
388
  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
dterei's avatar
dterei committed
389

390
        ; this_mod <- getModule
dterei's avatar
dterei committed
391
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
392
              ; dep_mods = imp_dep_mods imports
dterei's avatar
dterei committed
393 394 395 396

                -- We want instance declarations from all home-package
                -- modules below this one, including boot modules, except
                -- ourselves.  The 'except ourselves' is so that we don't
397 398 399 400
                -- get the instances from this module's hs-boot file.  This
                -- filtering also ensures that we don't see instances from
                -- modules batch (@--make@) compiled before this one, but
                -- which are not below this one.
dterei's avatar
dterei committed
401 402 403
              ; want_instances :: ModuleName -> Bool
              ; want_instances mod = mod `elemUFM` dep_mods
                                   && mod /= moduleName this_mod
dterei's avatar
dterei committed
404
              ; (home_insts, home_fam_insts) = hptInstances hsc_env
405
                                                            want_instances
dterei's avatar
dterei committed
406
              } ;
407

dterei's avatar
dterei committed
408
                -- Record boot-file info in the EPS, so that it's
dterei's avatar
dterei committed
409 410 411
                -- visible to loadHiBootInterface in tcRnSrcDecls,
                -- and any other incrementally-performed imports
        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
412

dterei's avatar
dterei committed
413
                -- Update the gbl env
dterei's avatar
dterei committed
414 415
        ; updGblEnv ( \ gbl ->
            gbl {
416
              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
dterei's avatar
dterei committed
417
              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
418
              tcg_rn_imports   = rn_imports,
dterei's avatar
dterei committed
419
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
dterei's avatar
dterei committed
420
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
421
                                                      home_fam_insts,
dterei's avatar
dterei committed
422 423 424 425 426
              tcg_hpc          = hpc_info
            }) $ do {

        ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
                -- Fail if there are any errors so far
dterei's avatar
dterei committed
427
                -- The error printing (if needed) takes advantage
dterei's avatar
dterei committed
428 429 430 431 432 433
                -- of the tcg_env we have now set
--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
        ; failIfErrsM

                -- Load any orphan-module and family instance-module
                -- interfaces, so that their rules and instance decls will be
434 435
                -- found.  But filter out a self hs-boot: these instances
                -- will be checked when we define them locally.
dterei's avatar
dterei committed
436
        ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
437
                               (filter (/= this_mod) (imp_orphs imports))
438

Simon Marlow's avatar
Simon Marlow committed
439
                -- Check type-family consistency
dterei's avatar
dterei committed
440 441
        ; traceRn (text "rn1: checking family instance consistency")
        ; let { dir_imp_mods = moduleEnvKeys
dterei's avatar
dterei committed
442
                             . imp_mods
dterei's avatar
dterei committed
443 444
                             $ imports }
        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
445

dterei's avatar
dterei committed
446
        ; getGblEnv } }
447

Austin Seipp's avatar
Austin Seipp committed
448 449 450
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
451
        Type-checking the top level of a module
Austin Seipp's avatar
Austin Seipp committed
452 453 454
*                                                                      *
************************************************************************
-}
455

Simon Peyton Jones's avatar
Simon Peyton Jones committed
456
tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
457 458 459
             -> Maybe (Located [LIE RdrName])   -- Exports
             -> [LHsDecl RdrName]               -- Declarations
             -> TcM TcGblEnv
dterei's avatar
dterei committed
460 461
        -- Returns the variables free in the decls
        -- Reason: solely to report unused imports and bindings
Simon Peyton Jones's avatar
Simon Peyton Jones committed
462
tcRnSrcDecls explicit_mod_hdr exports decls
dterei's avatar
dterei committed
463
 = do {         -- Do all the declarations
Simon Peyton Jones's avatar
Simon Peyton Jones committed
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
        ((tcg_env, tcl_env), lie) <- captureConstraints $
              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                              checkMain explicit_mod_hdr
                 ; return (tcg_env, tcl_env) }
      ; setEnvs (tcg_env, tcl_env) $ do {

#ifdef GHCI
        -- Run all module finalizers
        let th_modfinalizers_var = tcg_th_modfinalizers tcg_env
      ; modfinalizers <- readTcRef th_modfinalizers_var
      ; writeTcRef th_modfinalizers_var []
      ; mapM_ runQuasi modfinalizers
#endif /* GHCI */

479
        -- wanted constraints from static forms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
480
      ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
481

dterei's avatar
dterei committed
482
             --         Finish simplifying class constraints
dterei's avatar
dterei committed
483 484
             --
             -- simplifyTop deals with constant or ambiguous InstIds.
dterei's avatar
dterei committed
485 486 487 488
             -- How could there be ambiguous ones?  They can only arise if a
             -- top-level decl falls under the monomorphism restriction
             -- and no subsequent decl instantiates its type.
             --
dterei's avatar
dterei committed
489
             -- We do this after checkMain, so that we use the type info
dterei's avatar
dterei committed
490
             -- that checkMain adds
dterei's avatar
dterei committed
491
             --
dterei's avatar
dterei committed
492 493
             -- We do it with both global and local env in scope:
             --  * the global env exposes the instances to simplifyTop
dterei's avatar
dterei committed
494
             --  * the local env exposes the local Ids to simplifyTop,
dterei's avatar
dterei committed
495
             --    so that we get better error messages (monomorphism restriction)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
496 497 498
      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
                        simplifyTop (andWC stWC lie)
      ; traceTc "Tc9" empty
499

Simon Peyton Jones's avatar
Simon Peyton Jones committed
500
      ; failIfErrsM     -- Don't zonk if there have been errors
dterei's avatar
dterei committed
501 502
                        -- It's a waste of time; and we may get debug warnings
                        -- about strangely-typed TyCons!
503

504 505
        -- Zonk the final code.  This must be done last.
        -- Even simplifyTop may do some unification.
506
        -- This pass also warns about missing type signatures
Simon Peyton Jones's avatar
Simon Peyton Jones committed
507
      ; let { TcGblEnv { tcg_type_env  = type_env,
508 509 510 511 512 513 514
                         tcg_binds     = binds,
                         tcg_sigs      = sig_ns,
                         tcg_ev_binds  = cur_ev_binds,
                         tcg_imp_specs = imp_specs,
                         tcg_rules     = rules,
                         tcg_vects     = vects,
                         tcg_fords     = fords } = tcg_env
515
            ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
516

Simon Peyton Jones's avatar
Simon Peyton Jones committed
517
      ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
518
            <- {-# SCC "zonkTopDecls" #-}
519 520
               zonkTopDecls all_ev_binds binds exports sig_ns rules vects
                            imp_specs fords ;
dterei's avatar
dterei committed
521

Simon Peyton Jones's avatar
Simon Peyton Jones committed
522
      ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids
523 524 525
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
                                   tcg_imp_specs = imp_specs',
dterei's avatar
dterei committed
526 527
                                   tcg_rules    = rules',
                                   tcg_vects    = vects',
528 529
                                   tcg_fords    = fords' } } ;

Simon Peyton Jones's avatar
Simon Peyton Jones committed
530
      ; setGlobalTypeEnv tcg_env' final_type_env
Austin Seipp's avatar
Austin Seipp committed
531

532
   } }
533

Simon Peyton Jones's avatar
Simon Peyton Jones committed
534
tc_rn_src_decls :: [LHsDecl RdrName]
gmainland's avatar
gmainland committed
535
                -> TcM (TcGblEnv, TcLclEnv)
dterei's avatar
dterei committed
536
-- Loops around dealing with each top level inter-splice group
537
-- in turn, until it's dealt with the entire module
Simon Peyton Jones's avatar
Simon Peyton Jones committed
538
tc_rn_src_decls ds
539
 = {-# SCC "tc_rn_src_decls" #-}
gmainland's avatar
gmainland committed
540
   do { (first_group, group_tail) <- findSplice ds
dterei's avatar
dterei committed
541
                -- If ds is [] we get ([], Nothing)
dterei's avatar
dterei committed
542

dterei's avatar
dterei committed
543
        -- Deal with decls up to, but not including, the first splice
Simon Peyton Jones's avatar
Simon Peyton Jones committed
544
      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
dterei's avatar
dterei committed
545
                -- rnTopSrcDecls fails if there are any errors
dterei's avatar
dterei committed
546

547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
#ifdef GHCI
        -- Get TH-generated top-level declarations and make sure they don't
        -- contain any splices since we don't handle that at the moment
      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
      ; th_ds <- readTcRef th_topdecls_var
      ; writeTcRef th_topdecls_var []

      ; (tcg_env, rn_decls) <-
            if null th_ds
            then return (tcg_env, rn_decls)
            else do { (th_group, th_group_tail) <- findSplice th_ds
                    ; case th_group_tail of
                        { Nothing -> return () ;
                        ; Just (SpliceDecl (L loc _) _, _)
                            -> setSrcSpan loc $
                               addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls"))
                        } ;
Austin Seipp's avatar
Austin Seipp committed
564

565 566
                    -- Rename TH-generated top-level declarations
                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
567
                      rnTopSrcDecls th_group
568 569

                    -- Dump generated top-level declarations
570
                    ; let msg = "top-level declarations added with addTopDecls"
571 572 573 574
                    ; traceSplice $ SpliceInfo { spliceDescription = msg
                                               , spliceIsDecl    = True
                                               , spliceSource    = Nothing
                                               , spliceGenerated = ppr th_rn_decls }
575 576 577 578 579 580

                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
                    }
#endif /* GHCI */

      -- Type check all declarations
gmainland's avatar
gmainland committed
581
      ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
582
                              tcTopSrcDecls rn_decls
583

dterei's avatar
dterei committed
584
        -- If there is no splice, we're nearly done
gmainland's avatar
gmainland committed
585 586
      ; setEnvs (tcg_env, tcl_env) $
        case group_tail of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
587
          { Nothing -> return (tcg_env, tcl_env)
588 589

#ifndef GHCI
gmainland's avatar
gmainland committed
590 591 592 593
            -- There shouldn't be a splice
          ; Just (SpliceDecl {}, _) ->
            failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
          }
594
#else
gmainland's avatar
gmainland committed
595 596 597
            -- If there's a splice, we must carry on
          ; Just (SpliceDecl (L _ splice) _, rest_ds) ->
            do { -- Rename the splice expression, and get its supporting decls
598
                 (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
gmainland's avatar
gmainland committed
599 600 601

                 -- Glue them on the front of the remaining decls and loop
               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
602
                 tc_rn_src_decls (spliced_decls ++ rest_ds)
gmainland's avatar
gmainland committed
603 604
               }
          }
605
#endif /* GHCI */
gmainland's avatar
gmainland committed
606
      }
607

Austin Seipp's avatar
Austin Seipp committed
608 609 610
{-
************************************************************************
*                                                                      *
dterei's avatar
dterei committed
611 612
        Compiling hs-boot source files, and
        comparing the hi-boot interface with the real thing
Austin Seipp's avatar
Austin Seipp committed
613 614 615
*                                                                      *
************************************************************************
-}
616

617 618
tcRnHsBootDecls :: HscSource -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls hsc_src decls
619
   = do { (first_group, group_tail) <- findSplice decls
620

dterei's avatar
dterei committed
621
                -- Rename the declarations
dterei's avatar
dterei committed
622 623
        ; (tcg_env, HsGroup {
                   hs_tyclds = tycl_decls,
dterei's avatar
dterei committed
624 625 626
                   hs_instds = inst_decls,
                   hs_derivds = deriv_decls,
                   hs_fords  = for_decls,
dterei's avatar
dterei committed
627 628 629
                   hs_defds  = def_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls,
dterei's avatar
dterei committed
630
                   hs_annds  = _,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
631
                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
632 633
        -- The empty list is for extra dependencies coming from .hs-boot files
        -- See Note [Extra dependencies from .hs-boot files] in RnSource
dterei's avatar
dterei committed
634 635 636 637 638
        ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {


                -- Check for illegal declarations
        ; case group_tail of
639
             Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
dterei's avatar
dterei committed
640
             Nothing                  -> return ()
641 642 643 644
        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
        ; mapM_ (badBootDecl hsc_src "default") def_decls
        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
        ; mapM_ (badBootDecl hsc_src "vect")    vect_decls
dterei's avatar
dterei committed
645

646
                -- Typecheck type/class/isntance decls
647
        ; traceTc "Tc2 (boot)" empty
dterei's avatar
dterei committed
648
        ; (tcg_env, inst_infos, _deriv_binds)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
649
             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
dterei's avatar
dterei committed
650 651 652
        ; setGblEnv tcg_env     $ do {

                -- Typecheck value declarations
dterei's avatar
dterei committed
653
        ; traceTc "Tc5" empty
dterei's avatar
dterei committed
654 655 656 657 658
        ; val_ids <- tcHsBootSigs val_binds

                -- Wrap up
                -- No simplification or zonking to do
        ; traceTc "Tc7a" empty
dterei's avatar
dterei committed
659 660
        ; gbl_env <- getGblEnv

dterei's avatar
dterei committed
661 662
                -- Make the final type-env
                -- Include the dfun_ids so that their type sigs
dterei's avatar
dterei committed
663
                -- are written into the interface file.
dterei's avatar
dterei committed
664 665
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
666 667 668
              -- Don't add the dictionaries for non-recursive case, we don't
              -- actually want to /define/ the instance, just an export list
              ; type_env2 | Just _ <- tcg_impl_rdr_env gbl_env = type_env1
669
                          | otherwise = extendTypeEnvWithIds type_env1 dfun_ids
dterei's avatar
dterei committed
670 671 672 673
              ; dfun_ids = map iDFunId inst_infos
              }

        ; setGlobalTypeEnv gbl_env type_env2
674
   }}
675
   ; traceTc "boot" (ppr lie); return gbl_env }
676

677
badBootDecl :: HscSource -> String -> Located decl -> TcM ()
678
badBootDecl _hsc_src what (L loc _)
dterei's avatar
dterei committed
679
  = addErrAt loc (char 'A' <+> text what
680
      <+> text "declaration is not (currently) allowed in a hs-boot file")
681

Austin Seipp's avatar
Austin Seipp committed
682
{-
683 684
Once we've typechecked the body of the module, we want to compare what
we've found (gathered in a TypeEnv) with the hi-boot details (if any).
Austin Seipp's avatar
Austin Seipp committed
685
-}
686

Simon Peyton Jones's avatar
Simon Peyton Jones committed
687
checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
688 689
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
690 691
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
692

Simon Peyton Jones's avatar
Simon Peyton Jones committed
693 694
checkHiBootIface tcg_env boot_info
  | NoSelfBoot <- boot_info  -- Common case
dterei's avatar
dterei committed
695
  = return tcg_env
696

Simon Peyton Jones's avatar
Simon Peyton Jones committed
697 698 699 700 701 702 703 704
  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
  = return tcg_env

  | SelfBoot { sb_mds = boot_details } <- boot_info
  , TcGblEnv { tcg_binds    = binds
             , tcg_insts    = local_insts
             , tcg_type_env = local_type_env
             , tcg_exports  = local_exports } <- tcg_env
705 706 707
  = do  { dfun_prs <- checkHiBootIface' local_insts local_type_env
                                        local_exports boot_details
        ; let boot_dfuns = map fst dfun_prs
708 709 710 711 712 713 714 715 716 717 718
              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                     | (boot_dfun, dfun) <- dfun_prs ]
              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
              tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }

        ; setGlobalTypeEnv tcg_env' type_env' }
             -- Update the global type env *including* the knot-tied one
             -- so that if the source module reads in an interface unfolding
             -- mentioning one of the dfuns from the boot module, then it
             -- can "see" that boot dfun.   See Trac #4003

Simon Peyton Jones's avatar
Simon Peyton Jones committed
719 720
  | otherwise = panic "checkHiBootIface: unreachable code"

721
checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
722
                  -> ModDetails -> TcM [(Id, Id)]
723 724
-- Variant which doesn't require a full TcGblEnv; you could get the
-- local components from another ModDetails.
725
--
Gabor Greif's avatar
Gabor Greif committed
726
-- We return a list of "impedance-matching" bindings for the dfuns
727 728 729 730
-- defined in the hs-boot file, such as
--           $fxEqT = $fEqT
-- We need these because the module and hi-boot file might differ in
-- the name it chose for the dfun.
731 732 733 734 735

checkHiBootIface'
        local_insts local_type_env local_exports
        (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
                      md_types = boot_type_env, md_exports = boot_exports })
dterei's avatar
dterei committed
736
  = do  { traceTc "checkHiBootIface" $ vcat
737
             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
738

dterei's avatar
dterei committed
739 740
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
741

dterei's avatar
dterei committed
742 743 744 745
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
                   "instances in boot files yet...")
746
            -- FIXME: Why?  The actual comparison is not hard, but what would
dterei's avatar
dterei committed
747 748
            --        be the equivalent to the dfun bindings returned for class
            --        instances?  We can't easily equate tycons...
749

dterei's avatar
dterei committed
750
                -- Check instance declarations
Gabor Greif's avatar
Gabor Greif committed
751
                -- and generate an impedance-matching binding
dterei's avatar
dterei committed
752
        ; mb_dfun_prs <- mapM check_inst boot_insts
753

754
        ; failIfErrsM
755

756
        ; return (catMaybes mb_dfun_prs) }
757

758
  where
dterei's avatar
dterei committed
759
    check_export boot_avail     -- boot_avail is exported by the boot iface
dterei's avatar
dterei committed
760
      | name `elem` dfun_names = return ()
dterei's avatar
dterei committed
761 762 763
      | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
                                                -- 'error' is handled by a rather gross hack
                                                -- (see comments in GHC.Err.hs-boot)
764

dterei's avatar
dterei committed
765
        -- Check that the actual module exports the same thing
766
      | not (null missing_names)
dterei's avatar
dterei committed
767
      = addErrAt (nameSrcSpan (head missing_names))
768
                 (missingBootThing True (head missing_names) "exported by")
769

dterei's avatar
dterei committed
770 771
        -- If the boot module does not *define* the thing, we are done
        -- (it simply re-exports it, and names match, so nothing further to do)
772
      | isNothing mb_boot_thing = return ()
773

dterei's avatar
dterei committed
774
        -- Check that the actual module also defines the thing, and
dterei's avatar
dterei committed
775
        -- then compare the definitions
776 777
      | Just real_thing <- lookupTypeEnv local_type_env name,
        Just boot_thing <- mb_boot_thing
778
      = checkBootDeclM True boot_thing real_thing
779

780
      | otherwise
781
      = addErrTc (missingBootThing True name "defined in")
782
      where
dterei's avatar
dterei committed
783 784 785 786 787
        name          = availName boot_avail
        mb_boot_thing = lookupTypeEnv boot_type_env name
        missing_names = case lookupNameEnv local_export_env name of
                          Nothing    -> [name]
                          Just avail -> availNames boot_avail `minusList` availNames avail
dterei's avatar
dterei committed
788

789 790
    dfun_names = map getName boot_insts

791 792
    local_export_env :: NameEnv AvailInfo
    local_export_env = availsToNameEnv local_exports
793

794
    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
dterei's avatar
dterei committed
795
        -- Returns a pair of the boot dfun in terms of the equivalent real dfun
796
    check_inst boot_inst
dterei's avatar
dterei committed
797
        = case [dfun | inst <- local_insts,
dterei's avatar
dterei committed
798
                       let dfun = instanceDFunId inst,
799 800 801 802 803 804
                       idType dfun `eqType` boot_dfun_ty ] of
            [] -> do { traceTc "check_inst" $ vcat
                          [ text "local_insts"  <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
                          , text "boot_inst"    <+> ppr boot_inst
                          , text "boot_dfun_ty" <+> ppr boot_dfun_ty
                          ]
805
                     ; addErrTc (instMisMatch True boot_inst); return Nothing }
dterei's avatar
dterei committed
806
            (dfun:_) -> return (Just (local_boot_dfun, dfun))
807 808 809 810 811 812 813
                     where
                        local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun)
                           -- Name from the /boot-file/ ClsInst, but type from the dfun
                           -- defined in /this module/.  That ensures that the TyCon etc
                           -- inside the type are the ones defined in this module, not
                           -- the ones gotten from the hi-boot file, which may have
                           -- a lot less info (Trac #T8743, comment:10).
dterei's avatar
dterei committed
814
        where
815 816 817
          boot_dfun      = instanceDFunId boot_inst
          boot_dfun_ty   = idType boot_dfun
          boot_dfun_name = idName boot_dfun
818

819 820 821 822 823 824 825
-- This has to compare the TyThing from the .hi-boot file to the TyThing
-- in the current source file.  We must be careful to allow alpha-renaming
-- where appropriate, and also the boot declaration is allowed to omit
-- constructors and class methods.
--
-- See rnfail055 for a good test of this stuff.

826 827 828 829 830 831
-- | Compares two things for equivalence between boot-file and normal code,
-- reporting an error if they don't match up.
checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
               -> TyThing -> TyThing -> TcM ()
checkBootDeclM is_boot boot_thing real_thing
  = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
832 833
       addErrAt (nameSrcSpan (getName boot_thing))
                (bootMisMatch is_boot err real_thing boot_thing)
834 835 836 837 838 839

-- | Compares the two things for equivalence between boot-file and normal
-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
-- failure. If the difference will be apparent to the user, @Just empty@ is
-- perfectly suitable.
checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
840 841

checkBootDecl (AnId id1) (AnId id2)
dterei's avatar
dterei committed
842
  = ASSERT(id1 == id2)
843 844
    check (idType id1 `eqType` idType id2)
          (text "The two types are different")
845 846

checkBootDecl (ATyCon tc1) (ATyCon tc2)
847 848
  = checkBootTyCon tc1 tc2

cactus's avatar
cactus committed
849
checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
batterseapower's avatar
batterseapower committed
850 851
  = pprPanic "checkBootDecl" (ppr dc1)

852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873
checkBootDecl _ _ = Just empty -- probably shouldn't happen

-- | Combines two potential error messages
andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
Nothing `andThenCheck` msg     = msg
msg     `andThenCheck` Nothing = msg
Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
infixr 0 `andThenCheck`

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, return the provided check
checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
checkUnless True  _ = Nothing
checkUnless False k = k

-- | Run the check provided for every pair of elements in the lists.
-- The provided SDoc should name the element type, in the plural.
checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
            -> Maybe SDoc
checkListBy check_fun as bs whats = go [] as bs
  where
    herald = text "The" <+> whats <+> text "do not match"
Austin Seipp's avatar
Austin Seipp committed
874

875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891
    go []   [] [] = Nothing
    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
    go docs (x:xs) (y:ys) = case check_fun x y of
      Just doc -> go (doc:docs) xs ys
      Nothing  -> go docs       xs ys
    go _    _  _ = Just (hang (herald <> colon)
                            2 (text "There are different numbers of" <+> whats))

-- | If the test in the first parameter is True, succeed with @Nothing@;
-- otherwise, fail with the given SDoc.
check :: Bool -> SDoc -> Maybe SDoc
check True  _   = Nothing
check False doc = Just doc

-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
checkSuccess :: Maybe SDoc
checkSuccess = Nothing
batterseapower's avatar
batterseapower committed
892 893

----------------
894
checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
batterseapower's avatar
batterseapower committed
895 896
checkBootTyCon tc1 tc2
  | not (eqKind (tyConKind tc1) (tyConKind tc2))
897
  = Just $ text "The types have different kinds"    -- First off, check the kind
batterseapower's avatar
batterseapower committed
898 899 900

  | Just c1 <- tyConClass_maybe tc1
  , Just c2 <- tyConClass_maybe tc2
901
  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
902
          = classExtraBigSig c1
903
        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
904
          = classExtraBigSig c2
905 906
  , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
  = let
907
       eqSig (id1, def_meth1) (id2, def_meth2)
908 909 910 911 912 913 914 915 916
         = check (name1 == name2)
                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
                  text "are different") `andThenCheck`
           check (eqTypeX env op_ty1 op_ty2)
                 (text "The types of" <+> pname1 <+>
                  text "are different") `andThenCheck`
           check (def_meth1 == def_meth2)
                 (text "The default methods associated with" <+> pname1 <+>
                  text "are different")
917
         where
918 919 920 921
          name1 = idName id1
          name2 = idName id2
          pname1 = quotes (ppr name1)
          pname2 = quotes (ppr name2)
batterseapower's avatar
batterseapower committed
922 923 924
          (_, rho_ty1) = splitForAllTys (idType id1)
          op_ty1 = funResultTy rho_ty1
          (_, rho_ty2) = splitForAllTys (idType id2)
925 926
          op_ty2 = funResultTy rho_ty2

927
       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
928 929 930
         = checkBootTyCon tc1 tc2 `andThenCheck`
           check (eqATDef def_ats1 def_ats2)
                 (text "The associated type defaults differ")
931

dreixel's avatar
dreixel committed
932
       -- Ignore the location of the defaults
933 934
       eqATDef Nothing             Nothing             = True
       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
Austin Seipp's avatar
Austin Seipp committed
935
       eqATDef _ _ = False
936

dterei's avatar
dterei committed
937
       eqFD (as1,bs1) (as2,bs2) =
938 939
         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
940
    in
941 942 943 944 945 946 947 948 949 950
    check (roles1 == roles2) roles_msg `andThenCheck`
          -- Checks kind of class
    check (eqListBy eqFD clas_fds1 clas_fds2)
          (text "The functional dependencies do not match") `andThenCheck`
    checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
                     -- Above tests for an "abstract" class
    check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
          (text "The class constraints do not match") `andThenCheck`
    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
    checkListBy eqAT ats1 ats2 (text "associated types")
951

952 953
  | Just syn_rhs1 <- synTyConRhs_maybe tc1
  , Just syn_rhs2 <- synTyConRhs_maybe tc2
954
  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
955
  = ASSERT(tc1 == tc2)
956 957 958 959 960 961 962 963 964 965
    check (roles1 == roles2) roles_msg `andThenCheck`
    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say

  | Just fam_flav1 <- famTyConFlav_maybe tc1
  , Just fam_flav2 <- famTyConFlav_maybe tc2
  = ASSERT(tc1 == tc2)
    let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
966
            = eqClosedFamilyAx ax1 ax2
967 968
        eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
        eqFamFlav _ _ = False
Jan Stolarek's avatar
Jan Stolarek committed
969 970
        injInfo1 = familyTyConInjectivityInfo tc1
        injInfo2 = familyTyConInjectivityInfo tc2
971
    in
Jan Stolarek's avatar
Jan Stolarek committed
972
    -- check equality of roles, family flavours and injectivity annotations
973
    check (roles1 == roles2) roles_msg `andThenCheck`
Jan Stolarek's avatar
Jan Stolarek committed
974 975
    check (eqFamFlav fam_flav1 fam_flav2) empty `andThenCheck`
    check (injInfo1 == injInfo2) empty
976 977

  | isAlgTyCon tc1 && isAlgTyCon tc2
978
  , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
979
  = ASSERT(tc1 == tc2)
980 981 982 983 984
    check (roles1 == roles2) roles_msg `andThenCheck`
    check (eqListBy (eqPredX env)
                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
          (text "The datatype contexts do not match") `andThenCheck`
    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
985

986
  | otherwise = Just empty   -- two very different types -- should be obvious
dterei's avatar
dterei committed
987
  where
988 989
    roles1 = tyConRoles tc1
    roles2 = tyConRoles tc2
990 991 992
    roles_msg = text "The roles do not match." $$
                (text "Roles on abstract types default to" <+>
                 quotes (text "representational") <+> text "in boot files.")
993 994

    eqAlgRhs tc (AbstractTyCon dis1) rhs2
995
      | dis1      = check (isGenInjAlgRhs rhs2)   --Check compatibility
996 997 998 999 1000 1001 1002
                          (text "The natures of the declarations for" <+>
                           quotes (ppr tc) <+> text "are different")
      | otherwise = checkSuccess
    eqAlgRhs _  DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
1003
        eqCon (data_con tc1) (data_con tc2)
1004 1005 1006
    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
                           text "definition with a" <+> quotes (text "newtype") <+>
                           text "definition")
1007 1008

    eqCon c1 c2
1009 1010 1011 1012 1013 1014
      =  check (name1 == name2)
               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
                text "differ") `andThenCheck`
         check (dataConIsInfix c1 == dataConIsInfix c2)
               (text "The fixities of" <+> pname1 <+>
                text "differ") `andThenCheck`
1015
         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027
               (text "The strictness annotations for" <+> pname1 <+>
                text "differ") `andThenCheck`
         check (dataConFieldLabels c1 == dataConFieldLabels c2)
               (text "The record label lists for" <+> pname1 <+>
                text "differ") `andThenCheck`
         check (eqType (dataConUserType c1) (dataConUserType c2))
               (text "The types for" <+> pname1 <+> text "differ")
      where
        name1 = dataConName c1
        name2 = dataConName c2
        pname1 = quotes (ppr name1)
        pname2 = quotes (ppr name2)
1028

1029 1030 1031 1032 1033
    eqClosedFamilyAx Nothing Nothing  = True
    eqClosedFamilyAx Nothing (Just _) = False
    eqClosedFamilyAx (Just _) Nothing = False
    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
                     (Just (CoAxiom { co_ax_branches = branches2 }))
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
1034 1035 1036 1037 1038
      =  numBranches branches1 == numBranches branches2
      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
      where
        branch_list1 = fromBranches branches1
        branch_list2 = fromBranches branches2
1039 1040 1041 1042 1043