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