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