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,
   9         TcResults(..)
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CmdLineOpts      ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
  15 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..) )
  16 import HsTypes          ( toHsType )
  17 import RnHsSyn          ( RenamedHsDecl )
  18 import TcHsSyn          ( TypecheckedMonoBinds,
  19                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  20                           zonkTopBinds, zonkForeignExports, zonkRules
  21                         )
  22
  23 import TcMonad
  24 import Inst             ( plusLIE )
  25 import TcBinds          ( tcTopBinds )
  26 import TcClassDcl       ( tcClassDecls2, mkImplicitClassBinds )
  27 import TcDefaults       ( tcDefaults )
  28 import TcEnv            ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
  29                           tcEnvTyCons, tcEnvClasses,  isLocalThing,
  30                           tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
  31                         )
  32 import TcRules          ( tcRules )
  33 import TcForeign        ( tcForeignImports, tcForeignExports )
  34 import TcIfaceSig       ( tcInterfaceSigs )
  35 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  36 import TcSimplify       ( tcSimplifyTop )
  37 import TcTyClsDecls     ( tcTyAndClassDecls )
  38 import TcTyDecls        ( mkImplicitDataBinds )
  39
  40 import CoreUnfold       ( unfoldingTemplate )
  41 import Type             ( funResultTy, splitForAllTys )
  42 import Bag              ( isEmptyBag )
  43 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
  44 import Id               ( idType, idUnfolding )
  45 import Module           ( Module )
  46 import Name             ( Name, toRdrName )
  47 import Name             ( nameEnvElts, lookupNameEnv )
  48 import TyCon            ( tyConGenInfo )
  49 import Util
  50 import BasicTypes       ( EP(..), Fixity )
  51 import Bag              ( isEmptyBag )
  52 import Outputable
  53 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  54                           PackageTypeEnv, DFunId, ModIface(..),
  55                           TypeEnv, extendTypeEnvList,
  56                           TyThing(..), mkTypeEnv )
  57 import List             ( partition )
  58 \end{code}
  59
  60 Outside-world interface:
  61 \begin{code}
  62
  63 -- Convenient type synonyms first:
  64 data TcResults
  65   = TcResults {
  66         tc_pcs     :: PersistentCompilerState,  -- Augmented with imported information,
  67                                                 -- (but not stuff from this module)
  68
  69         -- All these fields have info *just for this module*
  70         tc_env     :: TypeEnv,                  -- The top level TypeEnv
  71         tc_insts   :: [DFunId],                 -- Instances
  72         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
  73         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
  74         tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
  75     }
  76
  77 ---------------
  78 typecheckModule
  79         :: DynFlags
  80         -> Module
  81         -> PersistentCompilerState
  82         -> HomeSymbolTable
  83         -> ModIface             -- Iface for this module
  84         -> PrintUnqualified     -- For error printing
  85         -> [RenamedHsDecl]
  86         -> IO (Maybe TcResults)
  87
  88 typecheckModule dflags this_mod pcs hst mod_iface unqual decls
  89   = do  { showPass dflags "Typechecker";
  90         ; env <- initTcEnv hst (pcs_PTE pcs)
  91
  92         ; (maybe_tc_result, (warns,errs)) <- initTc dflags env (tcModule pcs hst get_fixity this_mod decls)
  93
  94         ; printErrorsAndWarnings unqual (errs,warns)
  95         ; printTcDump dflags maybe_tc_result
  96
  97         ; if isEmptyBag errs then
  98              return maybe_tc_result
  99            else
 100              return Nothing
 101         }
 102   where
 103     fixity_env = mi_fixities mod_iface
 104
 105     get_fixity :: Name -> Maybe Fixity
 106     get_fixity nm = lookupNameEnv fixity_env nm
 107 \end{code}
 108
 109 The internal monster:
 110 \begin{code}
 111 tcModule :: PersistentCompilerState
 112          -> HomeSymbolTable
 113          -> (Name -> Maybe Fixity)
 114          -> Module
 115          -> [RenamedHsDecl]
 116          -> TcM TcResults
 117
 118 tcModule pcs hst get_fixity this_mod decls
 119   =              -- Type-check the type and class decls
 120     fixTc (\ ~(unf_env, _, _, _, _) ->
 121           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 122           -- which is done lazily [ie failure just drops the pragma
 123           -- without having any global-failure effect].
 124           --
 125           -- unf_env is also used to get the pragama info
 126           -- for imported dfuns and default methods
 127
 128 --      traceTc (text "Tc1")                    `thenNF_Tc_`
 129         tcTyAndClassDecls unf_env decls         `thenTc` \ env ->
 130         tcSetEnv env                            $
 131         let
 132             classes = tcEnvClasses env
 133             tycons  = tcEnvTyCons env   -- INCLUDES tycons derived from classes
 134         in
 135
 136                 -- Typecheck the instance decls, includes deriving
 137 --      traceTc (text "Tc2")    `thenNF_Tc_`
 138         tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 139                          hst unf_env get_fixity this_mod
 140                          tycons decls           `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
 141         tcSetInstEnv inst_env                   $
 142
 143         -- Interface type signatures
 144         -- We tie a knot so that the Ids read out of interfaces are in scope
 145         --   when we read their pragmas.
 146         -- What we rely on is that pragmas are typechecked lazily; if
 147         --   any type errors are found (ie there's an inconsistency)
 148         --   we silently discard the pragma
 149         -- We must do this before mkImplicitDataBinds (which comes next), since
 150         -- the latter looks up unpackCStringId, for example, which is usually
 151         -- imported
 152 --      traceTc (text "Tc3")                    `thenNF_Tc_`
 153         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
 154         tcExtendGlobalValEnv sig_ids            $
 155
 156         -- Create any necessary record selector Ids and their bindings
 157         -- "Necessary" includes data and newtype declarations
 158         -- We don't create bindings for dictionary constructors;
 159         -- they are always fully applied, and the bindings are just there
 160         -- to support partial applications
 161         mkImplicitDataBinds  this_mod tycons    `thenTc`    \ (data_ids, imp_data_binds) ->
 162         mkImplicitClassBinds this_mod classes   `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
 163
 164         -- Extend the global value environment with
 165         --      (a) constructors
 166         --      (b) record selectors
 167         --      (c) class op selectors
 168         --      (d) default-method ids... where? I can't see where these are
 169         --          put into the envt, and I'm worried that the zonking phase
 170         --          will find they aren't there and complain.
 171         tcExtendGlobalValEnv data_ids           $
 172         tcExtendGlobalValEnv cls_ids            $
 173         tcGetEnv                                        `thenTc` \ unf_env ->
 174         returnTc (unf_env, new_pcs_insts, local_inst_info, deriv_binds,
 175                            imp_data_binds `AndMonoBinds` imp_cls_binds)
 176     )           `thenTc` \ (env, new_pcs_insts, local_inst_info, deriv_binds, data_cls_binds) ->
 177
 178     tcSetEnv env                                $
 179
 180         -- Foreign import declarations next
 181 --  traceTc (text "Tc4")                        `thenNF_Tc_`
 182     tcForeignImports decls                      `thenTc`    \ (fo_ids, foi_decls) ->
 183     tcExtendGlobalValEnv fo_ids                 $
 184
 185         -- Default declarations
 186     tcDefaults decls                            `thenTc` \ defaulting_tys ->
 187     tcSetDefaultTys defaulting_tys              $
 188
 189         -- Value declarations next.
 190         -- We also typecheck any extra binds that came out of the "deriving" process
 191 --  traceTc (text "Tc5")                                        `thenNF_Tc_`
 192     tcTopBinds (get_binds decls `ThenBinds` deriv_binds)        `thenTc` \ ((val_binds, env), lie_valdecls) ->
 193     tcSetEnv env $
 194
 195         -- Foreign export declarations next
 196 --  traceTc (text "Tc6")                `thenNF_Tc_`
 197     tcForeignExports decls              `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 198
 199         -- Second pass over class and instance declarations,
 200         -- to compile the bindings themselves.
 201 --  traceTc (text "Tc7")                        `thenNF_Tc_`
 202     tcInstDecls2  local_inst_info               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 203 --  traceTc (text "Tc8")                        `thenNF_Tc_`
 204     tcClassDecls2 this_mod decls                `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 205     tcRules (pcs_rules pcs) this_mod decls      `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
 206
 207          -- Deal with constant or ambiguous InstIds.  How could
 208          -- there be ambiguous ones?  They can only arise if a
 209          -- top-level decl falls under the monomorphism
 210          -- restriction, and no subsequent decl instantiates its
 211          -- type.  (Usually, ambiguous type variables are resolved
 212          -- during the generalisation step.)
 213     let
 214         lie_alldecls = lie_valdecls     `plusLIE`
 215                    lie_instdecls        `plusLIE`
 216                    lie_clasdecls        `plusLIE`
 217                    lie_fodecls          `plusLIE`
 218                    lie_rules
 219     in
 220     tcSimplifyTop lie_alldecls                  `thenTc` \ const_inst_binds ->
 221
 222         -- Backsubstitution.    This must be done last.
 223         -- Even tcSimplifyTop may do some unification.
 224     let
 225         all_binds = data_cls_binds      `AndMonoBinds`
 226                     val_binds           `AndMonoBinds`
 227                     inst_binds          `AndMonoBinds`
 228                     cls_dm_binds        `AndMonoBinds`
 229                     const_inst_binds    `AndMonoBinds`
 230                     foe_binds
 231     in
 232 --  traceTc (text "Tc9")                `thenNF_Tc_`
 233     zonkTopBinds all_binds              `thenNF_Tc` \ (all_binds', final_env)  ->
 234     tcSetEnv final_env                  $
 235         -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 236     zonkForeignExports foe_decls        `thenNF_Tc` \ foe_decls' ->
 237     zonkRules local_rules               `thenNF_Tc` \ local_rules' ->
 238
 239
 240     let (local_things, imported_things) = partition (isLocalThing this_mod)
 241                                                     (nameEnvElts (getTcGEnv final_env))
 242
 243         local_type_env :: TypeEnv
 244         local_type_env = mkTypeEnv local_things
 245
 246         new_pte :: PackageTypeEnv
 247         new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 248
 249         final_pcs :: PersistentCompilerState
 250         final_pcs = pcs { pcs_PTE   = new_pte,
 251                           pcs_insts = new_pcs_insts,
 252                           pcs_rules = new_pcs_rules
 253                     }
 254     in
 255 --  traceTc (text "Tc10")               `thenNF_Tc_`
 256     returnTc (TcResults { tc_pcs     = final_pcs,
 257                           tc_env     = local_type_env,
 258                           tc_binds   = all_binds',
 259                           tc_insts   = map iDFunId local_inst_info,
 260                           tc_fords   = foi_decls ++ foe_decls',
 261                           tc_rules   = local_rules'
 262                         }
 263     )
 264
 265 get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 266 \end{code}
 267
 268
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection{Dumping output}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 \begin{code}
 277 printTcDump dflags Nothing = return ()
 278 printTcDump dflags (Just results)
 279   = do dumpIfSet_dyn dflags Opt_D_dump_types
 280                      "Type signatures" (dump_sigs results)
 281        dumpIfSet_dyn dflags Opt_D_dump_tc
 282                      "Typechecked" (dump_tc results)
 283
 284 dump_tc results
 285   = vcat [ppr (tc_binds results),
 286           pp_rules (tc_rules results),
 287           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 288     ]
 289
 290 dump_sigs results       -- Print type signatures
 291   =     -- Convert to HsType so that we get source-language style printing
 292         -- And sort by RdrName
 293     vcat $ map ppr_sig $ sortLt lt_sig $
 294     [ (toRdrName id, toHsType (idType id))
 295     | AnId id <- nameEnvElts (tc_env results),
 296       want_sig id
 297     ]
 298   where
 299     lt_sig (n1,_) (n2,_) = n1 < n2
 300     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 301
 302     want_sig id | opt_PprStyle_Debug = True
 303                 | otherwise          = True     -- For now
 304
 305 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 306                            vcat (map ppr_gen_tycon tcs),
 307                            ptext SLIT("#-}")
 308                      ]
 309
 310 -- x&y are now Id's, not CoreExpr's
 311 ppr_gen_tycon tycon
 312   | Just ep <- tyConGenInfo tycon
 313   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 314
 315   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 316
 317 ppr_ep (EP from to)
 318   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 319            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 320            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 321     ]
 322   where
 323     (_,from_tau) = splitForAllTys (idType from)
 324
 325 pp_rules [] = empty
 326 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 327                     nest 4 (vcat (map ppr rs)),
 328                     ptext SLIT("#-}")]
 329 \end{code}