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          ( tcTopBindsAndThen )
  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       ( buildInstanceEnv, 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 import 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_binds   :: TypecheckedMonoBinds,
  75         tc_insts   :: InstEnv,                  -- Instances, just for this module
  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 mod
  88   = do { us <- mkSplitUniqSupply 'a' ;
  89
  90          env <- initTcEnv global_symbol_table global_inst_env ;
  91
  92          (maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod)
  93
  94          printErrorsAndWarnings errs warns ;
  95
  96          case maybe_result of {
  97             Nothing      -> return Nothing ;
  98             Just results -> do {
  99
 100          dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
 101          dumpIfSet opt_D_dump_tc    "Typechecked"     (dump_tc   results) ;
 102
 103          if isEmptyBag errs then
 104             return Nothing
 105          else
 106
 107          let    groups :: FiniteMap Module TypeEnv
 108                 groups = groupTyThings (nameEnvElts (tc_env results))
 109
 110                 local_type_env :: TypeEnv
 111                 local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
 112
 113                 new_pst :: PackageSymbolTable
 114                 new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod)
 115            ;
 116          return (Just (pcs {pcsPST = new_pst},
 117                        results {tc_env = local_type_env}))
 118     }}}
 119   where
 120     global_symbol_table = pcsPST pcs `plusModuleEnv` hst
 121
 122     global_inst_env     = foldModuleEnv (plusInstEnv . instEnv) (pcsInsts pcs) gst
 123         -- For now, make the total instance envt by simply
 124         -- folding together all the instances we can find anywhere
 125 \end{code}
 126
 127 The internal monster:
 128 \begin{code}
 129 tcModule :: PersistentRenamerState
 130          -> RenamedHsModule     -- input
 131          -> TcM TcResults       -- output
 132
 133 tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
 134   = tcAddSrcLoc src_loc $       -- record where we're starting
 135
 136     fixTc (\ ~(unf_env ,_) ->
 137         -- (unf_env :: TcEnv) is used for type-checking interface pragmas
 138         -- which is done lazily [ie failure just drops the pragma
 139         -- without having any global-failure effect].
 140         --
 141         -- unf_env is also used to get the pragama info
 142         -- for imported dfuns and default methods
 143
 144                  -- Type-check the type and class decls
 145         tcTyAndClassDecls unf_env decls         `thenTc` \ env ->
 146         tcSetEnv env $
 147
 148                  -- Typecheck the instance decls, includes deriving
 149         tcInstDecls1 prs unf_env decls
 150                      (mkThisModule mod_name)    `thenTc` \ (inst_info, deriv_binds) ->
 151
 152         buildInstanceEnv inst_info      `thenNF_Tc` \ inst_env ->
 153
 154         tcSetInstEnv inst_env $
 155         let
 156             classes      = tcEnvClasses env
 157             tycons       = tcEnvTyCons env      -- INCLUDES tycons derived from classes
 158             local_classes = filter isLocallyDefined classes
 159             local_tycons  = [ tc | tc <- tycons,
 160                                    isLocallyDefined tc,
 161                                    not (isClassTyCon tc)
 162                             ]
 163                                 -- For local_tycons, filter out the ones derived from classes
 164                                 -- Otherwise the latter show up in interface files
 165         in
 166
 167             -- Default declarations
 168         tcDefaults decls                `thenTc` \ defaulting_tys ->
 169         tcSetDefaultTys defaulting_tys  $
 170
 171         -- Interface type signatures
 172         -- We tie a knot so that the Ids read out of interfaces are in scope
 173         --   when we read their pragmas.
 174         -- What we rely on is that pragmas are typechecked lazily; if
 175         --   any type errors are found (ie there's an inconsistency)
 176         --   we silently discard the pragma
 177         -- We must do this before mkImplicitDataBinds (which comes next), since
 178         -- the latter looks up unpackCStringId, for example, which is usually
 179         -- imported
 180         tcInterfaceSigs unf_env decls           `thenTc` \ sig_ids ->
 181         tcExtendGlobalValEnv sig_ids            $
 182
 183         -- Create any necessary record selector Ids and their bindings
 184         -- "Necessary" includes data and newtype declarations
 185         -- We don't create bindings for dictionary constructors;
 186         -- they are always fully applied, and the bindings are just there
 187         -- to support partial applications
 188         mkImplicitDataBinds tycons              `thenTc`    \ (data_ids, imp_data_binds) ->
 189         mkImplicitClassBinds classes            `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
 190
 191         -- Extend the global value environment with
 192         --      (a) constructors
 193         --      (b) record selectors
 194         --      (c) class op selectors
 195         --      (d) default-method ids... where? I can't see where these are
 196         --          put into the envt, and I'm worried that the zonking phase
 197         --          will find they aren't there and complain.
 198         tcExtendGlobalValEnv data_ids           $
 199         tcExtendGlobalValEnv cls_ids            $
 200
 201             -- foreign import declarations next.
 202         tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
 203         tcExtendGlobalValEnv fo_ids             $
 204
 205         -- Value declarations next.
 206         -- We also typecheck any extra binds that came out of the "deriving" process
 207         tcTopBindsAndThen
 208             (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
 209             (get_val_decls decls `ThenBinds` deriv_binds)
 210             (   tcGetEnv                                `thenNF_Tc` \ env ->
 211                 returnTc ((EmptyMonoBinds, env), emptyLIE)
 212             )                           `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
 213         tcSetEnv final_env $
 214
 215             -- foreign export declarations next.
 216         tcForeignExports decls          `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 217
 218                 -- Second pass over class and instance declarations,
 219                 -- to compile the bindings themselves.
 220         tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 221         tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 222         tcRules decls                   `thenNF_Tc` \ (lie_rules,     rules) ->
 223
 224
 225              -- Deal with constant or ambiguous InstIds.  How could
 226              -- there be ambiguous ones?  They can only arise if a
 227              -- top-level decl falls under the monomorphism
 228              -- restriction, and no subsequent decl instantiates its
 229              -- type.  (Usually, ambiguous type variables are resolved
 230              -- during the generalisation step.)
 231         let
 232             lie_alldecls = lie_valdecls  `plusLIE`
 233                            lie_instdecls `plusLIE`
 234                            lie_clasdecls `plusLIE`
 235                            lie_fodecls   `plusLIE`
 236                            lie_rules
 237         in
 238         tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
 239
 240                 -- Check that Main defines main
 241         (if mod_name == mAIN_Name then
 242                 tcLookupGlobal_maybe mainName           `thenNF_Tc` \ maybe_main ->
 243                 case maybe_main of
 244                    Just (AnId _) -> returnTc ()
 245                    other         -> addErrTc noMainErr
 246          else
 247                 returnTc ()
 248         )                                       `thenTc_`
 249
 250             -- Backsubstitution.    This must be done last.
 251             -- Even tcSimplifyTop may do some unification.
 252         let
 253             all_binds = imp_data_binds          `AndMonoBinds`
 254                         imp_cls_binds           `AndMonoBinds`
 255                         val_binds               `AndMonoBinds`
 256                         inst_binds              `AndMonoBinds`
 257                         cls_dm_binds            `AndMonoBinds`
 258                         const_inst_binds        `AndMonoBinds`
 259                         foe_binds
 260         in
 261         zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', really_final_env)  ->
 262         tcSetEnv really_final_env       $
 263                 -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 264
 265         zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
 266         zonkRules rules                 `thenNF_Tc` \ rules' ->
 267
 268         returnTc (really_final_env,
 269                   (TcResults {  tc_env     = tcGEnv really_final_env,
 270                                 tc_binds   = all_binds',
 271                                 tc_insts   = inst_info,
 272                                 tc_fords   = foi_decls ++ foe_decls',
 273                                 tc_rules   = rules'
 274                  }))
 275
 276     -- End of outer fix loop
 277     ) `thenTc` \ (final_env, stuff) ->
 278     returnTc stuff
 279
 280 get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 281 \end{code}
 282
 283
 284 \begin{code}
 285 noMainErr
 286   = hsep [ptext SLIT("Module"), quotes (pprModuleName 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 dump_tc results
 299   = vcat [ppr (tc_binds results),
 300           pp_rules (tc_rules results),
 301           ppr_gen_tycons (tc_tycons results)
 302     ]
 303
 304 dump_sigs results       -- Print type signatures
 305   =     -- Convert to HsType so that we get source-language style printing
 306         -- And sort by RdrName
 307     vcat $ map ppr_sig $ sortLt lt_sig $
 308     [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
 309                                             want_sig id
 310     ]
 311   where
 312     lt_sig (n1,_) (n2,_) = n1 < n2
 313     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 314
 315     want_sig id | opt_PprStyle_Debug = True
 316                 | otherwise          = isLocallyDefined n &&
 317                                        isGlobalName n &&
 318                                        not (isSysOcc (nameOccName n))
 319                                      where
 320                                        n = idName id
 321
 322 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 323                            vcat (map ppr_gen_tycon (filter isLocallyDefined tcs)),
 324                            ptext SLIT("#-}")
 325                      ]
 326
 327 -- x&y are now Id's, not CoreExpr's
 328 ppr_gen_tycon tycon
 329   | Just ep <- tyConGenInfo tycon
 330   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 331
 332   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 333
 334 ppr_ep (EP from to)
 335   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 336            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 337            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 338     ]
 339   where
 340     (_,from_tau) = splitForAllTys (idType from)
 341
 342 pp_rules [] = empty
 343 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 344                     nest 4 (vcat (map ppr rs)),
 345                     ptext SLIT("#-}")]
 346 \end{code}