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