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                 -- When relinking this module from its interface-file decls
 353                 -- we'll have IfaceRules that are in fact local to this module
 354                 -- That's the reason we we get any local_rules out here
 355
 356         tcGetEnv                                                `thenTc` \ unf_env ->
 357         let
 358             all_things = nameEnvElts (getTcGEnv unf_env)
 359
 360              -- sometimes we're compiling in the context of a package module
 361              -- (on the GHCi command line, for example).  In this case, we
 362              -- want to treat everything we pulled in as an imported thing.
 363             imported_things
 364                 | isHomeModule this_mod
 365                         = filter (not . isLocalThing this_mod) all_things
 366                 | otherwise
 367                         = all_things
 368
 369             new_pte :: PackageTypeEnv
 370             new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 371
 372             new_pcs :: PersistentCompilerState
 373             new_pcs = pcs { pcs_PTE   = new_pte,
 374                             pcs_insts = new_pcs_insts,
 375                             pcs_rules = new_pcs_rules
 376                       }
 377         in
 378         returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
 379     )
 380   where
 381     tycl_decls  = [d | TyClD d <- decls]
 382     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
 383 \end{code}
 384
 385 %************************************************************************
 386 %*                                                                      *
 387 \subsection{Checking the type of main}
 388 %*                                                                      *
 389 %************************************************************************
 390
 391 We must check that in module Main,
 392         a) main is defined
 393         b) main :: forall a1...an. IO t,  for some type t
 394
 395 If we have
 396         main = error "Urk"
 397 then the type of main will be
 398         main :: forall a. a
 399 and that should pass the test too.
 400
 401 So we just instantiate the type and unify with IO t, and declare
 402 victory if doing so succeeds.
 403
 404 \begin{code}
 405 tcCheckMain :: Module -> TcM ()
 406 tcCheckMain this_mod
 407   | not (moduleName this_mod == mAIN_Name )
 408   = returnTc ()
 409
 410   | otherwise
 411   =     -- First unify the main_id with IO t, for any old t
 412     tcLookup_maybe mainName             `thenNF_Tc` \ maybe_thing ->
 413     case maybe_thing of
 414         Just (ATcId main_id) -> check_main_ty (idType main_id)
 415         other                -> addErrTc noMainErr
 416   where
 417     check_main_ty main_ty
 418       = tcInstType main_ty              `thenNF_Tc` \ (tvs, theta, main_tau) ->
 419         newTyVarTy liftedTypeKind       `thenNF_Tc` \ arg_ty ->
 420         tcLookupTyCon ioTyConName       `thenNF_Tc` \ ioTyCon ->
 421         tcAddErrCtxtM (mainTypeCtxt main_ty)    $
 422         if not (null theta) then
 423                 failWithTc empty        -- Context has the error message
 424         else
 425         unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
 426
 427 mainTypeCtxt main_ty tidy_env
 428   = zonkTcType main_ty          `thenNF_Tc` \ main_ty' ->
 429     returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
 430                                  quotes (ppr (tidyType tidy_env main_ty')))
 431
 432 noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 433                   ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
 434 \end{code}
 435
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection{Dumping output}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 printTcDump dflags Nothing = return ()
 445 printTcDump dflags (Just (_, results))
 446   = do dumpIfSet_dyn dflags Opt_D_dump_types
 447                      "Type signatures" (dump_sigs results)
 448        dumpIfSet_dyn dflags Opt_D_dump_tc
 449                      "Typechecked" (dump_tc results)
 450
 451 dump_tc results
 452   = vcat [ppr (tc_binds results),
 453           pp_rules (tc_rules results),
 454           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 455     ]
 456
 457 dump_sigs results       -- Print type signatures
 458   =     -- Convert to HsType so that we get source-language style printing
 459         -- And sort by RdrName
 460     vcat $ map ppr_sig $ sortLt lt_sig $
 461     [ (toRdrName id, toHsType (idType id))
 462     | AnId id <- nameEnvElts (tc_env results),
 463       want_sig id
 464     ]
 465   where
 466     lt_sig (n1,_) (n2,_) = n1 < n2
 467     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 468
 469     want_sig id | opt_PprStyle_Debug = True
 470                 | otherwise          = isLocalId id && isGlobalName (idName id)
 471         -- isLocalId ignores data constructors, records selectors etc
 472         -- The isGlobalName ignores local dictionary and method bindings
 473         -- that the type checker has invented.  User-defined things have
 474         -- Global names.
 475
 476 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 477                            vcat (map ppr_gen_tycon tcs),
 478                            ptext SLIT("#-}")
 479                      ]
 480
 481 -- x&y are now Id's, not CoreExpr's
 482 ppr_gen_tycon tycon
 483   | Just ep <- tyConGenInfo tycon
 484   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 485
 486   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 487
 488 ppr_ep (EP from to)
 489   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 490            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 491            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 492     ]
 493   where
 494     (_,from_tau) = splitForAllTys (idType from)
 495
 496 pp_rules [] = empty
 497 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 498                     nest 4 (vcat (map ppr rs)),
 499                     ptext SLIT("#-}")]
 500 \end{code}