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