ghc/compiler/typecheck/TcModule.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 module TcModule (
   8         typecheckModule,
   9         TcResults,
  10         TcDDumpDeriv
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CmdLineOpts      ( opt_D_dump_tc, opt_D_dump_deriv )
  16 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
  17 import RnHsSyn          ( RenamedHsModule )
  18 import TcHsSyn          ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds,
  19                           TypecheckedForeignDecl, zonkForeignExports
  20                         )
  21
  22 import TcMonad
  23 import Inst             ( Inst, emptyLIE, plusLIE )
  24 import TcBinds          ( tcTopBindsAndThen )
  25 import TcClassDcl       ( tcClassDecls2 )
  26 import TcDefaults       ( tcDefaults )
  27 import TcEnv            ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv,
  28                           getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
  29                           lookupGlobalByKey, tcSetGlobalValEnv,
  30                           tcLookupTyCon, initEnv, GlobalValueEnv
  31                         )
  32 import TcExpr           ( tcId )
  33 import TcForeign        ( tcForeignImports, tcForeignExports )
  34 import TcIfaceSig       ( tcInterfaceSigs )
  35 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  36 import TcInstUtil       ( buildInstanceEnvs, classDataCon, InstInfo )
  37 import TcSimplify       ( tcSimplifyTop )
  38 import TcTyClsDecls     ( tcTyAndClassDecls1 )
  39 import TcTyDecls        ( mkDataBinds )
  40 import TcType           ( TcType, typeToTcType,
  41                           TcKind, kindToTcKind
  42                         )
  43
  44 import RnMonad          ( RnNameSupply )
  45 import Bag              ( isEmptyBag )
  46 import ErrUtils         ( ErrMsg,
  47                           pprBagOfErrors, dumpIfSet
  48                         )
  49 import Id               ( Id, idType )
  50 import Name             ( Name, nameUnique, isLocallyDefined, pprModule, NamedThing(..) )
  51 import TyCon            ( TyCon, tyConKind )
  52 import DataCon          ( dataConId )
  53 import Class            ( Class, classSelIds, classTyCon )
  54 import Type             ( mkTyConApp, Type )
  55 import TysWiredIn       ( unitTy )
  56 import PrelMods         ( mAIN )
  57 import PrelInfo         ( main_NAME, ioTyCon_NAME,
  58                           thinAirIdNames, setThinAirIds
  59                         )
  60 import TcUnify          ( unifyTauTy )
  61 import Unique           ( Unique  )
  62 import UniqSupply       ( UniqSupply )
  63 import Util
  64 import Bag              ( Bag, isEmptyBag )
  65 import Outputable
  66
  67 import IOExts
  68 \end{code}
  69
  70 Outside-world interface:
  71 \begin{code}
  72
  73 -- Convenient type synonyms first:
  74 type TcResults
  75   = (TypecheckedMonoBinds,
  76      [TyCon], [Class],
  77      Bag InstInfo,              -- Instance declaration information
  78      [TypecheckedForeignDecl], -- foreign import & exports.
  79      TcDDumpDeriv,
  80      GlobalValueEnv,
  81      [Id]                       -- The thin-air Ids
  82      )
  83
  84 type TcDDumpDeriv = SDoc
  85
  86 ---------------
  87 typecheckModule
  88         :: UniqSupply
  89         -> RnNameSupply
  90         -> RenamedHsModule
  91         -> IO (Maybe TcResults)
  92
  93 typecheckModule us rn_name_supply mod
  94   = let
  95       (maybe_result, warns, errs) =
  96                 initTc us initEnv (tcModule rn_name_supply mod)
  97     in
  98     print_errs warns    >>
  99     print_errs errs     >>
 100
 101     dumpIfSet opt_D_dump_tc "Typechecked"
 102         (case maybe_result of
 103             Just (binds, _, _, _, _, _, _, _) -> ppr binds
 104             Nothing                           -> text "Typecheck failed")   >>
 105
 106     dumpIfSet opt_D_dump_deriv "Derived instances"
 107         (case maybe_result of
 108             Just (_, _, _, _, _, dump_deriv, _, _) -> dump_deriv
 109             Nothing                                -> empty)                >>
 110
 111     -- write the thin-air Id map
 112     (case maybe_result of
 113         Just (_, _, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
 114         Nothing                                  -> return ()
 115     )                                                                   >>
 116
 117     return (if isEmptyBag errs then
 118                 maybe_result
 119             else
 120                 Nothing)
 121
 122 print_errs errs
 123   | isEmptyBag errs = return ()
 124   | otherwise       = printErrs (pprBagOfErrors errs)
 125 \end{code}
 126
 127 The internal monster:
 128 \begin{code}
 129 tcModule :: RnNameSupply        -- for renaming derivings
 130          -> RenamedHsModule     -- input
 131          -> TcM s TcResults     -- output
 132
 133 tcModule rn_name_supply
 134         (HsModule mod_name verion exports imports fixities decls src_loc)
 135   = tcAddSrcLoc src_loc $       -- record where we're starting
 136
 137     fixTc (\ ~(unf_env ,_) ->
 138         -- unf_env is used for type-checking interface pragmas
 139         -- which is done lazily [ie failure just drops the pragma
 140         -- without having any global-failure effect].
 141         --
 142         -- unf_env is also used to get the pragam info
 143         -- for imported dfuns and default methods
 144
 145             -- The knot for instance information.  This isn't used at all
 146             -- till we type-check value declarations
 147         fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
 148
 149                  -- Type-check the type and class decls
 150                 -- trace "tcTyAndClassDecls:"   $
 151                 tcTyAndClassDecls1 unf_env rec_inst_mapper decls        `thenTc` \ env ->
 152
 153                 -- trace "tc3" $
 154                     -- Typecheck the instance decls, includes deriving
 155                 tcSetEnv env (
 156                 -- trace "tcInstDecls:" $
 157                 tcInstDecls1 unf_env decls mod_name rn_name_supply
 158                 )                               `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
 159
 160                 -- trace "tc4" $
 161                 buildInstanceEnvs inst_info     `thenNF_Tc` \ inst_mapper ->
 162
 163                 returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
 164
 165         -- End of inner fix loop
 166         ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
 167
 168         -- trace "tc5" $
 169         tcSetEnv env $
 170
 171             -- Default declarations
 172         tcDefaults decls                `thenTc` \ defaulting_tys ->
 173         tcSetDefaultTys defaulting_tys  $
 174
 175         -- Create any necessary record selector Ids and their bindings
 176         -- "Necessary" includes data and newtype declarations
 177         -- We don't create bindings for dictionary constructors;
 178         -- they are always fully applied, and the bindings are just there
 179         -- to support partial applications
 180         let
 181             tycons       = getEnv_TyCons env
 182             classes      = getEnv_Classes env
 183             local_tycons  = filter isLocallyDefined tycons
 184             local_classes = filter isLocallyDefined classes
 185         in
 186         mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
 187
 188         -- Extend the global value environment with
 189         --      (a) constructors
 190         --      (b) record selectors
 191         --      (c) class op selectors
 192         --      (d) default-method ids
 193         tcExtendGlobalValEnv data_ids                           $
 194         tcExtendGlobalValEnv (concat (map classSelIds classes)) $
 195
 196         -- Extend the TyCon envt with the tycons corresponding to
 197         -- the classes, and the global value environment with the
 198         -- corresponding data cons.
 199         --  They are mentioned in types in interface files.
 200         tcExtendGlobalValEnv (map (dataConId . classDataCon) classes)           $
 201         tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon))
 202                          | clas <- classes,
 203                            let tycon = classTyCon clas
 204                          ]                              $
 205
 206             -- Interface type signatures
 207             -- We tie a knot so that the Ids read out of interfaces are in scope
 208             --   when we read their pragmas.
 209             -- What we rely on is that pragmas are typechecked lazily; if
 210             --   any type errors are found (ie there's an inconsistency)
 211             --   we silently discard the pragma
 212         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
 213         tcExtendGlobalValEnv sig_ids            $
 214
 215             -- foreign import declarations next.
 216         tcForeignImports decls          `thenTc`    \ (fo_ids, foi_decls) ->
 217         tcExtendGlobalValEnv fo_ids             $
 218
 219         -- Value declarations next.
 220         -- We also typecheck any extra binds that came out of the "deriving" process
 221 --      trace "tc6"                     $
 222         tcTopBindsAndThen
 223             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
 224             (get_val_decls decls `ThenBinds` deriv_binds)
 225             (   tcGetEnv                `thenNF_Tc` \ env ->
 226 --              tcGetUnique     `thenNF_Tc` \ uniq ->
 227 --              pprTrace "tc7" (ppr uniq) $
 228                 returnTc ((EmptyMonoBinds, env), emptyLIE)
 229             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
 230         tcSetEnv final_env $
 231
 232             -- foreign export declarations next.
 233         tcForeignExports decls          `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 234
 235                 -- Second pass over class and instance declarations,
 236                 -- to compile the bindings themselves.
 237 --      pprTrace "tc8" emtpy $
 238         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 239         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
 240
 241         -- Check that "main" has the right signature
 242         tcCheckMainSig mod_name         `thenTc_`
 243
 244              -- Deal with constant or ambiguous InstIds.  How could
 245              -- there be ambiguous ones?  They can only arise if a
 246              -- top-level decl falls under the monomorphism
 247              -- restriction, and no subsequent decl instantiates its
 248              -- type.  (Usually, ambiguous type variables are resolved
 249              -- during the generalisation step.)
 250         let
 251             lie_alldecls = lie_valdecls  `plusLIE`
 252                            lie_instdecls `plusLIE`
 253                            lie_clasdecls `plusLIE`
 254                            lie_fodecls
 255         in
 256         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
 257
 258
 259             -- Backsubstitution.    This must be done last.
 260             -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
 261         let
 262             all_binds = data_binds              `AndMonoBinds`
 263                         val_binds               `AndMonoBinds`
 264                         inst_binds              `AndMonoBinds`
 265                         cls_binds               `AndMonoBinds`
 266                         const_inst_binds        `AndMonoBinds`
 267                         foe_binds
 268         in
 269         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', really_final_env)  ->
 270         tcSetGlobalValEnv really_final_env $
 271         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 272
 273         let
 274            thin_air_ids = map (lookupGlobalByKey really_final_env . nameUnique) thinAirIdNames
 275                 -- When looking up the thin-air names we must use
 276                 -- a global env that includes the zonked locally-defined Ids too
 277                 -- Hence using really_final_env
 278         in
 279         returnTc (really_final_env,
 280                   (all_binds', local_tycons, local_classes, inst_info,
 281                    foi_decls ++ foe_decls',
 282                    ddump_deriv, really_final_env, thin_air_ids))
 283
 284     -- End of outer fix loop
 285     ) `thenTc` \ (final_env, stuff) ->
 286     returnTc stuff
 287
 288 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 289 \end{code}
 290
 291
 292 \begin{code}
 293 tcCheckMainSig mod_name
 294   | mod_name /= mAIN
 295   = returnTc ()         -- A non-main module
 296
 297   | otherwise
 298   =     -- Check that main is defined
 299     tcLookupTyCon ioTyCon_NAME          `thenTc`    \ (_,_,ioTyCon) ->
 300     tcLookupLocalValue main_NAME        `thenNF_Tc` \ maybe_main_id ->
 301     case maybe_main_id of {
 302         Nothing  -> failWithTc noMainErr ;
 303         Just main_id   ->
 304
 305         -- Check that it has the right type (or a more general one)
 306     let
 307         expected_tau = typeToTcType (mkTyConApp ioTyCon [unitTy])
 308     in
 309     tcId main_NAME                              `thenNF_Tc` \ (_, lie, main_tau) ->
 310     tcSetErrCtxt mainTyCheckCtxt $
 311     unifyTauTy expected_tau
 312                main_tau                 `thenTc_`
 313     checkTc (isEmptyBag lie) (mainTyMisMatch expected_tau (idType main_id))
 314     }
 315
 316
 317 mainTyCheckCtxt
 318   = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
 319
 320 noMainErr
 321   = hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
 322           ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
 323
 324 mainTyMisMatch :: TcType s -> TcType s -> ErrMsg
 325 mainTyMisMatch expected actual
 326   = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")])
 327          4 (vcat [
 328                         hsep [ptext SLIT("Expected:"), ppr expected],
 329                         hsep [ptext SLIT("Inferred:"), ppr actual]
 330                      ])
 331 \end{code}