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, typecheckExpr, TcResults(..)
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CmdLineOpts      ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
  14 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
  15                           isIfaceRuleDecl, nullBinds, andMonoBindList
  16                         )
  17 import HsTypes          ( toHsType )
  18 import PrelNames        ( mAIN_Name, mainName, ioTyConName, printName )
  19 import RnHsSyn          ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
  20 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
  21                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  22                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
  23                           zonkExpr
  24                         )
  25
  26
  27 import TcMonad
  28 import TcType           ( newTyVarTy, zonkTcType, tcInstType )
  29 import TcUnify          ( unifyTauTy )
  30 import Inst             ( plusLIE )
  31 import VarSet           ( varSetElems )
  32 import TcBinds          ( tcTopBinds )
  33 import TcClassDcl       ( tcClassDecls2 )
  34 import TcDefaults       ( tcDefaults, defaultDefaultTys )
  35 import TcExpr           ( tcMonoExpr )
  36 import TcEnv            ( TcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
  37                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
  38                           TcTyThing(..), tcLookupTyCon
  39                         )
  40 import TcRules          ( tcIfaceRules, tcSourceRules )
  41 import TcForeign        ( tcForeignImports, tcForeignExports )
  42 import TcIfaceSig       ( tcInterfaceSigs )
  43 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  44 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
  45 import TcTyClsDecls     ( tcTyAndClassDecls )
  46
  47 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
  48 import Type             ( funResultTy, splitForAllTys, mkForAllTys, mkFunTys,
  49                           liftedTypeKind, openTypeKind, mkTyConApp, tyVarsOfType, tidyType )
  50 import ErrUtils         ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
  51 import Id               ( idType, idName, isLocalId, idUnfolding )
  52 import Module           ( Module, isHomeModule, moduleName )
  53 import Name             ( Name, toRdrName, isGlobalName )
  54 import Name             ( nameEnvElts, lookupNameEnv )
  55 import TyCon            ( tyConGenInfo )
  56 import Util
  57 import BasicTypes       ( EP(..), Fixity )
  58 import Outputable
  59 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  60                           PackageTypeEnv, ModIface(..),
  61                           TypeEnv, extendTypeEnvList,
  62                           TyThing(..), implicitTyThingIds,
  63                           mkTypeEnv
  64                         )
  65 \end{code}
  66
  67 Outside-world interface:
  68 \begin{code}
  69
  70 -- Convenient type synonyms first:
  71 data TcResults
  72   = TcResults {
  73         -- All these fields have info *just for this module*
  74         tc_env     :: TypeEnv,                  -- The top level TypeEnv
  75         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
  76         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
  77         tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
  78     }
  79
  80 ---------------
  81 typecheckModule
  82         :: DynFlags
  83         -> PersistentCompilerState
  84         -> HomeSymbolTable
  85         -> ModIface             -- Iface for this module
  86         -> PrintUnqualified     -- For error printing
  87         -> [RenamedHsDecl]
  88         -> IO (Maybe (PersistentCompilerState, TcResults))
  89                         -- The new PCS is Augmented with imported information,
  90                                                 -- (but not stuff from this module)
  91
  92
  93 typecheckModule dflags pcs hst mod_iface unqual decls
  94   = do  { maybe_tc_result <- typecheck dflags pcs hst unqual $
  95                              tcModule pcs hst get_fixity this_mod decls
  96         ; printTcDump dflags maybe_tc_result
  97         ; return maybe_tc_result }
  98   where
  99     this_mod   = mi_module   mod_iface
 100     fixity_env = mi_fixities mod_iface
 101
 102     get_fixity :: Name -> Maybe Fixity
 103     get_fixity nm = lookupNameEnv fixity_env nm
 104
 105 ---------------
 106 typecheckExpr :: DynFlags
 107               -> Bool                   -- True <=> wrap in 'print' to get a result of IO type
 108               -> PersistentCompilerState
 109               -> HomeSymbolTable
 110               -> PrintUnqualified       -- For error printing
 111               -> Module
 112               -> (RenamedHsExpr,        -- The expression itself
 113                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
 114               -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
 115
 116 typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
 117   = typecheck dflags pcs hst unqual $
 118
 119          -- use the default default settings, i.e. [Integer, Double]
 120     tcSetDefaultTys defaultDefaultTys $
 121     tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 122     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
 123
 124     tcSetEnv env                                $
 125     tc_expr expr                                        `thenTc` \ (expr', lie, expr_ty) ->
 126     tcSimplifyInfer smpl_doc
 127         (varSetElems (tyVarsOfType expr_ty)) lie        `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
 128     tcSimplifyTop lie_free                              `thenTc` \ const_binds ->
 129     let all_expr = mkHsLet const_binds  $
 130                    TyLam qtvs           $
 131                    DictLam dict_ids     $
 132                    mkHsLet dict_binds   $
 133                    expr'
 134         all_expr_ty = mkForAllTys qtvs (mkFunTys (map idType dict_ids) expr_ty)
 135     in
 136     zonkExpr all_expr                                   `thenNF_Tc` \ zonked_expr ->
 137     zonkTcType all_expr_ty                              `thenNF_Tc` \ zonked_ty ->
 138     ioToTc (dumpIfSet_dyn dflags
 139                 Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
 140     returnTc (new_pcs, zonked_expr, zonked_ty)
 141
 142   where
 143     get_fixity :: Name -> Maybe Fixity
 144     get_fixity n = pprPanic "typecheckExpr" (ppr n)
 145
 146     smpl_doc = ptext SLIT("main expression")
 147
 148         -- Typecheck it, wrapping in 'print' if necessary to
 149         -- get a result of type IO t.  Returns the result type
 150         -- that is free in the result type
 151     tc_expr e
 152         | wrap_io   = tryTc_ (tc_io_expr (HsApp (HsVar printName) e))   -- Recovery case
 153                              (tc_io_expr e)                             -- Main case
 154         | otherwise = newTyVarTy openTypeKind   `thenTc` \ ty ->
 155                       tcMonoExpr expr ty        `thenTc` \ (expr', lie) ->
 156                       returnTc (expr', lie, ty)
 157
 158         where
 159                 -- (tc_io_expr e) typechecks 'e' if that gives a result of IO t,
 160                 -- or 'print e' otherwise.  Either way the result is of type IO t
 161           tc_io_expr e = newTyVarTy openTypeKind        `thenTc` \ ty ->
 162                          tcLookupTyCon ioTyConName      `thenNF_Tc` \ ioTyCon ->
 163                          let
 164                             res_ty = mkTyConApp ioTyCon [ty]
 165                          in
 166                          tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
 167                          returnTc (expr', lie, res_ty)
 168
 169 ---------------
 170 typecheck :: DynFlags
 171           -> PersistentCompilerState
 172           -> HomeSymbolTable
 173           -> PrintUnqualified   -- For error printing
 174           -> TcM r
 175           -> IO (Maybe r)
 176
 177 typecheck dflags pcs hst unqual thing_inside
 178  = do   { showPass dflags "Typechecker";
 179         ; env <- initTcEnv hst (pcs_PTE pcs)
 180
 181         ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 182
 183         ; printErrorsAndWarnings unqual errs
 184
 185         ; if errorsFound errs then
 186              return Nothing
 187            else
 188              return maybe_tc_result
 189         }
 190 \end{code}
 191
 192 The internal monster:
 193 \begin{code}
 194 tcModule :: PersistentCompilerState
 195          -> HomeSymbolTable
 196          -> (Name -> Maybe Fixity)
 197          -> Module
 198          -> [RenamedHsDecl]
 199          -> TcM (PersistentCompilerState, TcResults)
 200
 201 tcModule pcs hst get_fixity this_mod decls
 202   =     -- Type-check the type and class decls, and all imported decls
 203         -- tcImports recovers internally, but if anything gave rise to
 204         -- an error we'd better stop now, to avoid a cascade
 205     checkNoErrsTc (
 206         tcImports pcs hst get_fixity this_mod decls
 207     )                                           `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 208
 209     tcSetEnv env                                $
 210
 211         -- Foreign import declarations next
 212 --  traceTc (text "Tc4")                        `thenNF_Tc_`
 213     tcForeignImports decls                      `thenTc`    \ (fo_ids, foi_decls) ->
 214     tcExtendGlobalValEnv fo_ids                 $
 215
 216         -- Default declarations
 217     tcDefaults decls                            `thenTc` \ defaulting_tys ->
 218     tcSetDefaultTys defaulting_tys              $
 219
 220         -- Value declarations next.
 221         -- We also typecheck any extra binds that came out of the "deriving" process
 222 --  traceTc (text "Tc5")                                `thenNF_Tc_`
 223     tcTopBinds (val_binds `ThenBinds` deriv_binds)      `thenTc` \ ((val_binds, env), lie_valdecls) ->
 224     tcSetEnv env $
 225
 226         -- Foreign export declarations next
 227 --  traceTc (text "Tc6")                `thenNF_Tc_`
 228     tcForeignExports decls              `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 229
 230         -- Second pass over class and instance declarations,
 231         -- to compile the bindings themselves.
 232     tcInstDecls2  local_inst_info               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 233     tcClassDecls2 this_mod tycl_decls           `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 234     tcSourceRules source_rules                  `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
 235
 236          -- Deal with constant or ambiguous InstIds.  How could
 237          -- there be ambiguous ones?  They can only arise if a
 238          -- top-level decl falls under the monomorphism
 239          -- restriction, and no subsequent decl instantiates its
 240          -- type.  (Usually, ambiguous type variables are resolved
 241          -- during the generalisation step.)
 242     let
 243         lie_alldecls = lie_valdecls     `plusLIE`
 244                        lie_instdecls    `plusLIE`
 245                        lie_clasdecls    `plusLIE`
 246                        lie_fodecls      `plusLIE`
 247                        lie_rules
 248     in
 249     tcSimplifyTop lie_alldecls                  `thenTc` \ const_inst_binds ->
 250
 251         -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
 252     tcCheckMain this_mod                        `thenTc_`
 253
 254         -- Backsubstitution.    This must be done last.
 255         -- Even tcSimplifyTop may do some unification.
 256     let
 257         all_binds = val_binds           `AndMonoBinds`
 258                     inst_binds          `AndMonoBinds`
 259                     cls_dm_binds        `AndMonoBinds`
 260                     const_inst_binds    `AndMonoBinds`
 261                     foe_binds
 262     in
 263 --  traceTc (text "Tc9")                `thenNF_Tc_`
 264     zonkTopBinds all_binds              `thenNF_Tc` \ (all_binds', final_env)  ->
 265     tcSetEnv final_env                  $
 266         -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 267     zonkForeignExports foe_decls        `thenNF_Tc` \ foe_decls' ->
 268     zonkRules more_local_rules          `thenNF_Tc` \ more_local_rules' ->
 269
 270
 271     let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
 272
 273         -- Create any necessary "implicit" bindings (data constructors etc)
 274         -- Should we create bindings for dictionary constructors?
 275         -- They are always fully applied, and the bindings are just there
 276         -- to support partial applications. But it's easier to let them through.
 277         implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
 278                                          | id <- implicitTyThingIds local_things
 279                                          , let unf = idUnfolding id
 280                                          , hasUnfolding unf
 281                                          ]
 282
 283         local_type_env :: TypeEnv
 284         local_type_env = mkTypeEnv local_things
 285
 286         all_local_rules = local_rules ++ more_local_rules'
 287     in
 288 --  traceTc (text "Tc10")               `thenNF_Tc_`
 289     returnTc (new_pcs,
 290               TcResults { tc_env     = local_type_env,
 291                           tc_binds   = implicit_binds `AndMonoBinds` all_binds',
 292                           tc_fords   = foi_decls ++ foe_decls',
 293                           tc_rules   = all_local_rules
 294                         }
 295     )
 296   where
 297     tycl_decls   = [d | TyClD d <- decls]
 298     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 299     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
 300 \end{code}
 301
 302
 303 \begin{code}
 304 tcImports :: PersistentCompilerState
 305           -> HomeSymbolTable
 306           -> (Name -> Maybe Fixity)
 307           -> Module
 308           -> [RenamedHsDecl]
 309           -> TcM (TcEnv, PersistentCompilerState,
 310                   [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
 311
 312 -- tcImports is a slight mis-nomer.
 313 -- It deals with everythign that could be an import:
 314 --      type and class decls
 315 --      interface signatures
 316 --      instance decls
 317 --      rule decls
 318 -- These can occur in source code too, of course
 319
 320 tcImports pcs hst get_fixity this_mod decls
 321   = fixTc (\ ~(unf_env, _, _, _, _) ->
 322           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 323           -- which is done lazily [ie failure just drops the pragma
 324           -- without having any global-failure effect].
 325           --
 326           -- unf_env is also used to get the pragama info
 327           -- for imported dfuns and default methods
 328
 329 --      traceTc (text "Tc1")                    `thenNF_Tc_`
 330         tcTyAndClassDecls unf_env tycl_decls    `thenTc` \ env ->
 331         tcSetEnv env                            $
 332
 333                 -- Typecheck the instance decls, includes deriving
 334 --      traceTc (text "Tc2")    `thenNF_Tc_`
 335         tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 336                      hst unf_env get_fixity this_mod
 337                      decls                      `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
 338         tcSetInstEnv inst_env                   $
 339
 340         -- Interface type signatures
 341         -- We tie a knot so that the Ids read out of interfaces are in scope
 342         --   when we read their pragmas.
 343         -- What we rely on is that pragmas are typechecked lazily; if
 344         --   any type errors are found (ie there's an inconsistency)
 345         --   we silently discard the pragma
 346 --      traceTc (text "Tc3")                    `thenNF_Tc_`
 347         tcInterfaceSigs unf_env tycl_decls      `thenTc` \ sig_ids ->
 348         tcExtendGlobalValEnv sig_ids            $
 349
 350
 351         tcIfaceRules (pcs_rules pcs) this_mod iface_rules       `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
 352
 353         tcGetEnv                                                `thenTc` \ unf_env ->
 354         let
 355             all_things = nameEnvElts (getTcGEnv unf_env)
 356
 357              -- sometimes we're compiling in the context of a package module
 358              -- (on the GHCi command line, for example).  In this case, we
 359              -- want to treat everything we pulled in as an imported thing.
 360             imported_things
 361                 | isHomeModule this_mod
 362                         = filter (not . isLocalThing this_mod) all_things
 363                 | otherwise
 364                         = all_things
 365
 366             new_pte :: PackageTypeEnv
 367             new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 368
 369             new_pcs :: PersistentCompilerState
 370             new_pcs = pcs { pcs_PTE   = new_pte,
 371                             pcs_insts = new_pcs_insts,
 372                             pcs_rules = new_pcs_rules
 373                       }
 374         in
 375         returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
 376     )
 377   where
 378     tycl_decls  = [d | TyClD d <- decls]
 379     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
 380 \end{code}
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection{Checking the type of main}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 We must check that in module Main,
 389         a) main is defined
 390         b) main :: forall a1...an. IO t,  for some type t
 391
 392 If we have
 393         main = error "Urk"
 394 then the type of main will be
 395         main :: forall a. a
 396 and that should pass the test too.
 397
 398 So we just instantiate the type and unify with IO t, and declare
 399 victory if doing so succeeds.
 400
 401 \begin{code}
 402 tcCheckMain :: Module -> TcM ()
 403 tcCheckMain this_mod
 404   | not (moduleName this_mod == mAIN_Name )
 405   = returnTc ()
 406
 407   | otherwise
 408   =     -- First unify the main_id with IO t, for any old t
 409     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
 410     case maybe_thing of
 411         Just (ATcId main_id) -> check_main_ty (idType main_id)
 412         other                -> addErrTc noMainErr
 413   where
 414     check_main_ty main_ty
 415       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
 416         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
 417         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
 418         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
 419         if not (null theta) then
 420                 failWithTc empty        -- Context has the error message
 421         else
 422         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
 423
 424 mainTypeCtxt main_ty tidy_env
 425   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
 426     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
 427                                  quotes (ppr (tidyType tidy_env main_ty')))
 428
 429 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 430                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
 431 \end{code}
 432
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection{Dumping output}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 \begin{code}
 441 printTcDump dflags Nothing = return ()
 442 printTcDump dflags (Just (_, results))
 443   = do dumpIfSet_dyn dflags Opt_D_dump_types
 444                      "Type signatures" (dump_sigs results)
 445        dumpIfSet_dyn dflags Opt_D_dump_tc
 446                      "Typechecked" (dump_tc results)
 447
 448 dump_tc results
 449   = vcat [ppr (tc_binds results),
 450           pp_rules (tc_rules results),
 451           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 452     ]
 453
 454 dump_sigs results       -- Print type signatures
 455   =     -- Convert to HsType so that we get source-language style printing
 456         -- And sort by RdrName
 457     vcat $ map ppr_sig $ sortLt lt_sig $
 458     [ (toRdrName id, toHsType (idType id))
 459     | AnId id <- nameEnvElts (tc_env results),
 460       want_sig id
 461     ]
 462   where
 463     lt_sig (n1,_) (n2,_) = n1 < n2
 464     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 465
 466     want_sig id | opt_PprStyle_Debug = True
 467                 | otherwise          = isLocalId id && isGlobalName (idName id)
 468         -- isLocalId ignores data constructors, records selectors etc
 469         -- The isGlobalName ignores local dictionary and method bindings
 470         -- that the type checker has invented.  User-defined things have
 471         -- Global names.
 472
 473 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 474                            vcat (map ppr_gen_tycon tcs),
 475                            ptext SLIT("#-}")
 476                      ]
 477
 478 -- x&y are now Id's, not CoreExpr's
 479 ppr_gen_tycon tycon
 480   | Just ep <- tyConGenInfo tycon
 481   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 482
 483   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 484
 485 ppr_ep (EP from to)
 486   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 487            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 488            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 489     ]
 490   where
 491     (_,from_tau) = splitForAllTys (idType from)
 492
 493 pp_rules [] = empty
 494 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 495                     nest 4 (vcat (map ppr rs)),
 496                     ptext SLIT("#-}")]
 497 \end{code}