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