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