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