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