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, tcLookupGlobal_maybe,
  29                           tcEnvTyCons, tcEnvClasses,
  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 )
  44 import Id               ( idType, idName, idUnfolding )
  45 import Module           ( Module, moduleName, plusModuleEnv )
  46 import Name             ( Name, nameOccName, isLocallyDefined, isGlobalName,
  47                           toRdrName, nameEnvElts, emptyNameEnv, lookupNameEnv
  48                         )
  49 import TyCon            ( tyConGenInfo, isClassTyCon )
  50 import OccName          ( isSysOcc )
  51 import PrelNames        ( mAIN_Name, mainName )
  52 import Maybes           ( thenMaybe )
  53 import Util
  54 import BasicTypes       ( EP(..), Fixity )
  55 import Bag              ( isEmptyBag )
  56 import Outputable
  57 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
  58                           PackageSymbolTable, DFunId, ModIface(..),
  59                           TypeEnv, extendTypeEnv, lookupTable,
  60                           TyThing(..), groupTyThings )
  61 import FiniteMap        ( FiniteMap, delFromFM, lookupWithDefaultFM )
  62 \end{code}
  63
  64 Outside-world interface:
  65 \begin{code}
  66
  67 -- Convenient type synonyms first:
  68 data TcResults
  69   = TcResults {
  70         tc_pcs     :: PersistentCompilerState,  -- Augmented with imported information,
  71                                                 -- (but not stuff from this module)
  72
  73         -- All these fields have info *just for this module*
  74         tc_env     :: TypeEnv,                  -- The top level TypeEnv
  75         tc_insts   :: [DFunId],                 -- Instances
  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         -> Module
  85         -> PersistentCompilerState
  86         -> HomeSymbolTable -> HomeIfaceTable
  87         -> [RenamedHsDecl]
  88         -> IO (Maybe TcResults)
  89
  90 typecheckModule dflags this_mod pcs hst hit decls
  91   = do  env <- initTcEnv global_symbol_table
  92
  93         (maybe_result, (errs,warns)) <- initTc dflags env tc_module
  94
  95         let { maybe_tc_result :: Maybe TcResults ;
  96               maybe_tc_result = case maybe_result of
  97                                   Nothing    -> Nothing
  98                                   Just (_,r) -> Just r }
  99
 100         printErrorsAndWarnings (errs,warns)
 101         printTcDump dflags maybe_tc_result
 102
 103         if isEmptyBag errs then
 104              return Nothing
 105            else
 106              return maybe_tc_result
 107   where
 108     global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
 109
 110     tc_module :: TcM (TcEnv, TcResults)
 111     tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env)
 112
 113     pit = pcs_PIT pcs
 114
 115     get_fixity :: Name -> Maybe Fixity
 116     get_fixity nm = lookupTable hit pit nm      `thenMaybe` \ iface ->
 117                     lookupNameEnv (mi_fixities iface) nm
 118 \end{code}
 119
 120 The internal monster:
 121 \begin{code}
 122 tcModule :: PersistentCompilerState
 123          -> HomeSymbolTable
 124          -> (Name -> Maybe Fixity)
 125          -> Module
 126          -> [RenamedHsDecl]
 127          -> TcEnv               -- The knot-tied environment
 128          -> TcM (TcEnv, TcResults)
 129
 130   -- (unf_env :: TcEnv) is used for type-checking interface pragmas
 131   -- which is done lazily [ie failure just drops the pragma
 132   -- without having any global-failure effect].
 133   --
 134   -- unf_env is also used to get the pragama info
 135   -- for imported dfuns and default methods
 136
 137 tcModule pcs hst get_fixity this_mod decls unf_env
 138   =              -- Type-check the type and class decls
 139     tcTyAndClassDecls unf_env decls             `thenTc` \ env ->
 140     tcSetEnv env                                $
 141     let
 142         classes       = tcEnvClasses env
 143         tycons        = tcEnvTyCons env -- INCLUDES tycons derived from classes
 144         local_tycons  = [ tc | tc <- tycons,
 145                                isLocallyDefined tc,
 146                                not (isClassTyCon tc)
 147                         ]
 148                         -- For local_tycons, filter out the ones derived from classes
 149                         -- Otherwise the latter show up in interface files
 150     in
 151
 152         -- Typecheck the instance decls, includes deriving
 153     tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 154                  hst unf_env get_fixity this_mod
 155                  local_tycons decls             `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
 156     tcSetInstEnv inst_env                       $
 157
 158         -- Default declarations
 159     tcDefaults decls                    `thenTc` \ defaulting_tys ->
 160     tcSetDefaultTys defaulting_tys      $
 161
 162     -- Interface type signatures
 163     -- We tie a knot so that the Ids read out of interfaces are in scope
 164     --   when we read their pragmas.
 165     -- What we rely on is that pragmas are typechecked lazily; if
 166     --   any type errors are found (ie there's an inconsistency)
 167     --   we silently discard the pragma
 168     -- We must do this before mkImplicitDataBinds (which comes next), since
 169     -- the latter looks up unpackCStringId, for example, which is usually
 170     -- imported
 171     tcInterfaceSigs unf_env decls               `thenTc` \ sig_ids ->
 172     tcExtendGlobalValEnv sig_ids                $
 173
 174     -- Create any necessary record selector Ids and their bindings
 175     -- "Necessary" includes data and newtype declarations
 176     -- We don't create bindings for dictionary constructors;
 177     -- they are always fully applied, and the bindings are just there
 178     -- to support partial applications
 179     mkImplicitDataBinds tycons                  `thenTc`    \ (data_ids, imp_data_binds) ->
 180     mkImplicitClassBinds classes                `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
 181
 182     -- Extend the global value environment with
 183     --  (a) constructors
 184     --  (b) record selectors
 185     --  (c) class op selectors
 186     --  (d) default-method ids... where? I can't see where these are
 187     --      put into the envt, and I'm worried that the zonking phase
 188     --      will find they aren't there and complain.
 189     tcExtendGlobalValEnv data_ids               $
 190     tcExtendGlobalValEnv cls_ids                $
 191
 192         -- Foreign import declarations next
 193     tcForeignImports decls                      `thenTc`    \ (fo_ids, foi_decls) ->
 194     tcExtendGlobalValEnv fo_ids                 $
 195
 196     -- Value declarations next.
 197     -- We also typecheck any extra binds that came out of the "deriving" process
 198     tcTopBinds (get_binds decls `ThenBinds` deriv_binds)        `thenTc` \ ((val_binds, env), lie_valdecls) ->
 199     tcSetEnv env $
 200
 201         -- Foreign export declarations next
 202     tcForeignExports decls              `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 203
 204         -- Second pass over class and instance declarations,
 205         -- to compile the bindings themselves.
 206     tcInstDecls2  local_inst_info               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 207     tcClassDecls2 decls                         `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 208     tcRules (pcs_rules pcs) this_mod decls      `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
 209
 210          -- Deal with constant or ambiguous InstIds.  How could
 211          -- there be ambiguous ones?  They can only arise if a
 212          -- top-level decl falls under the monomorphism
 213          -- restriction, and no subsequent decl instantiates its
 214          -- type.  (Usually, ambiguous type variables are resolved
 215          -- during the generalisation step.)
 216     let
 217         lie_alldecls = lie_valdecls     `plusLIE`
 218                    lie_instdecls        `plusLIE`
 219                    lie_clasdecls        `plusLIE`
 220                    lie_fodecls          `plusLIE`
 221                    lie_rules
 222     in
 223     tcSimplifyTop lie_alldecls                  `thenTc` \ const_inst_binds ->
 224
 225         -- Check that Main defines main
 226     checkMain this_mod                          `thenTc_`
 227
 228         -- Backsubstitution.    This must be done last.
 229         -- Even tcSimplifyTop may do some unification.
 230     let
 231         all_binds = imp_data_binds      `AndMonoBinds`
 232                     imp_cls_binds       `AndMonoBinds`
 233                     val_binds           `AndMonoBinds`
 234                     inst_binds          `AndMonoBinds`
 235                     cls_dm_binds        `AndMonoBinds`
 236                     const_inst_binds    `AndMonoBinds`
 237                     foe_binds
 238     in
 239     zonkTopBinds all_binds              `thenNF_Tc` \ (all_binds', final_env)  ->
 240     tcSetEnv final_env                  $
 241         -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 242     zonkForeignExports foe_decls        `thenNF_Tc` \ foe_decls' ->
 243     zonkRules local_rules               `thenNF_Tc` \ local_rules' ->
 244
 245
 246     let groups :: FiniteMap Module TypeEnv
 247         groups = groupTyThings (nameEnvElts (getTcGEnv final_env))
 248
 249         local_type_env :: TypeEnv
 250         local_type_env = lookupWithDefaultFM groups emptyNameEnv this_mod
 251
 252         new_pst :: PackageSymbolTable
 253         new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod)
 254
 255         final_pcs :: PersistentCompilerState
 256         final_pcs = pcs { pcs_PST   = new_pst,
 257                           pcs_insts = new_pcs_insts,
 258                           pcs_rules = new_pcs_rules
 259                     }
 260     in
 261     returnTc (final_env,
 262               TcResults { tc_pcs     = final_pcs,
 263                           tc_env     = local_type_env,
 264                           tc_binds   = all_binds',
 265                           tc_insts   = map iDFunId local_inst_info,
 266                           tc_fords   = foi_decls ++ foe_decls',
 267                           tc_rules   = local_rules'
 268                         })
 269
 270 get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 271 \end{code}
 272
 273
 274 \begin{code}
 275 checkMain :: Module -> TcM ()
 276 checkMain this_mod
 277   | moduleName this_mod == mAIN_Name
 278   = tcLookupGlobal_maybe mainName               `thenNF_Tc` \ maybe_main ->
 279     case maybe_main of
 280         Just (AnId _) -> returnTc ()
 281         other         -> addErrTc noMainErr
 282
 283   | otherwise = returnTc ()
 284
 285 noMainErr
 286   = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
 287           ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{Dumping output}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297 \begin{code}
 298 printTcDump dflags Nothing = return ()
 299 printTcDump dflags (Just results)
 300   = do dumpIfSet_dyn dflags Opt_D_dump_types
 301                      "Type signatures" (dump_sigs results)
 302        dumpIfSet_dyn dflags Opt_D_dump_tc
 303                      "Typechecked" (dump_tc results)
 304
 305 dump_tc results
 306   = vcat [ppr (tc_binds results),
 307           pp_rules (tc_rules results),
 308           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 309     ]
 310
 311 dump_sigs results       -- Print type signatures
 312   =     -- Convert to HsType so that we get source-language style printing
 313         -- And sort by RdrName
 314     vcat $ map ppr_sig $ sortLt lt_sig $
 315     [(toRdrName id, toHsType (idType id))
 316         | AnId id <- nameEnvElts (tc_env results),
 317           want_sig id
 318     ]
 319   where
 320     lt_sig (n1,_) (n2,_) = n1 < n2
 321     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 322
 323     want_sig id | opt_PprStyle_Debug = True
 324                 | otherwise          = isLocallyDefined n &&
 325                                        isGlobalName n &&
 326                                        not (isSysOcc (nameOccName n))
 327                                      where
 328                                        n = idName id
 329
 330 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 331                            vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)),
 332                            ptext SLIT("#-}")
 333                      ]
 334
 335 -- x&y are now Id's, not CoreExpr's
 336 ppr_gen_tycon tycon
 337   | Just ep <- tyConGenInfo tycon
 338   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 339
 340   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 341
 342 ppr_ep (EP from to)
 343   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 344            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 345            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 346     ]
 347   where
 348     (_,from_tau) = splitForAllTys (idType from)
 349
 350 pp_rules [] = empty
 351 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 352                     nest 4 (vcat (map ppr rs)),
 353                     ptext SLIT("#-}")]
 354 \end{code}