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, typecheckExpr, TcResults(..)
   9     ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CmdLineOpts      ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
  14 import HsSyn            ( HsBinds(..), MonoBinds(..), HsDecl(..),
  15                           isIfaceRuleDecl, nullBinds, andMonoBindList
  16                         )
  17 import HsTypes          ( toHsType )
  18 import RnHsSyn          ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
  19 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedHsExpr,
  20                           TypecheckedForeignDecl, TypecheckedRuleDecl,
  21                           zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet
  22                         )
  23
  24
  25 import TcMonad
  26 import TcType           ( newTyVarTy )
  27 import Inst             ( plusLIE )
  28 import TcBinds          ( tcTopBinds )
  29 import TcClassDcl       ( tcClassDecls2 )
  30 import TcDefaults       ( tcDefaults, defaultDefaultTys )
  31 import TcExpr           ( tcMonoExpr )
  32 import TcEnv            ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
  33                           isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
  34                         )
  35 import TcRules          ( tcIfaceRules, tcSourceRules )
  36 import TcForeign        ( tcForeignImports, tcForeignExports )
  37 import TcIfaceSig       ( tcInterfaceSigs )
  38 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  39 import TcSimplify       ( tcSimplifyTop )
  40 import TcTyClsDecls     ( tcTyAndClassDecls )
  41
  42 import CoreUnfold       ( unfoldingTemplate, hasUnfolding )
  43 import Type             ( funResultTy, splitForAllTys, openTypeKind )
  44 import Bag              ( isEmptyBag )
  45 import ErrUtils         ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
  46 import Id               ( idType, idUnfolding )
  47 import Module           ( Module )
  48 import Name             ( Name, toRdrName )
  49 import Name             ( nameEnvElts, lookupNameEnv )
  50 import TyCon            ( tyConGenInfo )
  51 import Util
  52 import BasicTypes       ( EP(..), Fixity )
  53 import Bag              ( isEmptyBag )
  54 import Outputable
  55 import HscTypes         ( PersistentCompilerState(..), HomeSymbolTable,
  56                           PackageTypeEnv, DFunId, ModIface(..),
  57                           TypeEnv, extendTypeEnvList,
  58                           TyThing(..), implicitTyThingIds,
  59                           mkTypeEnv
  60                         )
  61 \end{code}
  62
  63 Outside-world interface:
  64 \begin{code}
  65
  66 -- Convenient type synonyms first:
  67 data TcResults
  68   = TcResults {
  69         -- All these fields have info *just for this module*
  70         tc_env     :: TypeEnv,                  -- The top level TypeEnv
  71         tc_insts   :: [DFunId],                 -- Instances
  72         tc_binds   :: TypecheckedMonoBinds,     -- Bindings
  73         tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
  74         tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
  75     }
  76
  77 ---------------
  78 typecheckModule
  79         :: DynFlags
  80         -> PersistentCompilerState
  81         -> HomeSymbolTable
  82         -> ModIface             -- Iface for this module
  83         -> PrintUnqualified     -- For error printing
  84         -> [RenamedHsDecl]
  85         -> IO (Maybe (PersistentCompilerState, TcResults))
  86                         -- The new PCS is Augmented with imported information,
  87                                                 -- (but not stuff from this module)
  88
  89
  90 typecheckModule dflags pcs hst mod_iface unqual decls
  91   = do  { maybe_tc_result <- typecheck dflags pcs hst unqual $
  92                              tcModule pcs hst get_fixity this_mod decls
  93         ; printTcDump dflags maybe_tc_result
  94         ; return maybe_tc_result }
  95   where
  96     this_mod   = mi_module   mod_iface
  97     fixity_env = mi_fixities mod_iface
  98
  99     get_fixity :: Name -> Maybe Fixity
 100     get_fixity nm = lookupNameEnv fixity_env nm
 101
 102 ---------------
 103 typecheckExpr :: DynFlags
 104               -> PersistentCompilerState
 105               -> HomeSymbolTable
 106               -> PrintUnqualified       -- For error printing
 107               -> Module
 108               -> (RenamedHsExpr,        -- The expression itself
 109                   [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
 110               -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr))
 111
 112 typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
 113   = typecheck dflags pcs hst unqual $
 114
 115          -- use the default default settings, i.e. [Integer, Double]
 116     tcSetDefaultTys defaultDefaultTys $
 117     tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 118     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
 119
 120     tcSetEnv env                                $
 121     newTyVarTy openTypeKind     `thenTc` \ ty ->
 122     tcMonoExpr expr ty          `thenTc` \ (expr', lie) ->
 123     tcSimplifyTop lie           `thenTc` \ binds ->
 124     returnTc (new_pcs, mkHsLet binds expr')
 125   where
 126     get_fixity :: Name -> Maybe Fixity
 127     get_fixity n = pprPanic "typecheckExpr" (ppr n)
 128
 129 ---------------
 130 typecheck :: DynFlags
 131           -> PersistentCompilerState
 132           -> HomeSymbolTable
 133           -> PrintUnqualified   -- For error printing
 134           -> TcM r
 135           -> IO (Maybe r)
 136
 137 typecheck dflags pcs hst unqual thing_inside
 138  = do   { showPass dflags "Typechecker";
 139         ; env <- initTcEnv hst (pcs_PTE pcs)
 140
 141         ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
 142
 143         ; printErrorsAndWarnings unqual (errs,warns)
 144
 145         ; if isEmptyBag errs then
 146              return maybe_tc_result
 147            else
 148              return Nothing
 149         }
 150 \end{code}
 151
 152 The internal monster:
 153 \begin{code}
 154 tcModule :: PersistentCompilerState
 155          -> HomeSymbolTable
 156          -> (Name -> Maybe Fixity)
 157          -> Module
 158          -> [RenamedHsDecl]
 159          -> TcM (PersistentCompilerState, TcResults)
 160
 161 tcModule pcs hst get_fixity this_mod decls
 162   =     -- Type-check the type and class decls, and all imported decls
 163     tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
 164
 165     tcSetEnv env                                $
 166
 167         -- Foreign import declarations next
 168 --  traceTc (text "Tc4")                        `thenNF_Tc_`
 169     tcForeignImports decls                      `thenTc`    \ (fo_ids, foi_decls) ->
 170     tcExtendGlobalValEnv fo_ids                 $
 171
 172         -- Default declarations
 173     tcDefaults decls                            `thenTc` \ defaulting_tys ->
 174     tcSetDefaultTys defaulting_tys              $
 175
 176         -- Value declarations next.
 177         -- We also typecheck any extra binds that came out of the "deriving" process
 178 --  traceTc (text "Tc5")                                `thenNF_Tc_`
 179     tcTopBinds (val_binds `ThenBinds` deriv_binds)      `thenTc` \ ((val_binds, env), lie_valdecls) ->
 180     tcSetEnv env $
 181
 182         -- Foreign export declarations next
 183 --  traceTc (text "Tc6")                `thenNF_Tc_`
 184     tcForeignExports decls              `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
 185
 186         -- Second pass over class and instance declarations,
 187         -- to compile the bindings themselves.
 188     tcInstDecls2  local_inst_info               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 189     tcClassDecls2 this_mod tycl_decls           `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
 190     tcSourceRules source_rules                  `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
 191
 192          -- Deal with constant or ambiguous InstIds.  How could
 193          -- there be ambiguous ones?  They can only arise if a
 194          -- top-level decl falls under the monomorphism
 195          -- restriction, and no subsequent decl instantiates its
 196          -- type.  (Usually, ambiguous type variables are resolved
 197          -- during the generalisation step.)
 198     let
 199         lie_alldecls = lie_valdecls     `plusLIE`
 200                        lie_instdecls    `plusLIE`
 201                        lie_clasdecls    `plusLIE`
 202                        lie_fodecls      `plusLIE`
 203                        lie_rules
 204     in
 205     tcSimplifyTop lie_alldecls                  `thenTc` \ const_inst_binds ->
 206
 207         -- Backsubstitution.    This must be done last.
 208         -- Even tcSimplifyTop may do some unification.
 209     let
 210         all_binds = val_binds           `AndMonoBinds`
 211                     inst_binds          `AndMonoBinds`
 212                     cls_dm_binds        `AndMonoBinds`
 213                     const_inst_binds    `AndMonoBinds`
 214                     foe_binds
 215     in
 216 --  traceTc (text "Tc9")                `thenNF_Tc_`
 217     zonkTopBinds all_binds              `thenNF_Tc` \ (all_binds', final_env)  ->
 218     tcSetEnv final_env                  $
 219         -- zonkTopBinds puts all the top-level Ids into the tcGEnv
 220     zonkForeignExports foe_decls        `thenNF_Tc` \ foe_decls' ->
 221     zonkRules more_local_rules          `thenNF_Tc` \ more_local_rules' ->
 222
 223
 224     let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
 225
 226         -- Create any necessary "implicit" bindings (data constructors etc)
 227         -- Should we create bindings for dictionary constructors?
 228         -- They are always fully applied, and the bindings are just there
 229         -- to support partial applications. But it's easier to let them through.
 230         implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
 231                                          | id <- implicitTyThingIds local_things
 232                                          , let unf = idUnfolding id
 233                                          , hasUnfolding unf
 234                                          ]
 235
 236         local_type_env :: TypeEnv
 237         local_type_env = mkTypeEnv local_things
 238
 239         all_local_rules = local_rules ++ more_local_rules'
 240     in
 241 --  traceTc (text "Tc10")               `thenNF_Tc_`
 242     returnTc (new_pcs,
 243               TcResults { tc_env     = local_type_env,
 244                           tc_binds   = implicit_binds `AndMonoBinds` all_binds',
 245                           tc_insts   = map iDFunId local_inst_info,
 246                           tc_fords   = foi_decls ++ foe_decls',
 247                           tc_rules   = all_local_rules
 248                         }
 249     )
 250   where
 251     tycl_decls   = [d | TyClD d <- decls]
 252     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
 253     source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
 254 \end{code}
 255
 256
 257 \begin{code}
 258 tcImports :: PersistentCompilerState
 259           -> HomeSymbolTable
 260           -> (Name -> Maybe Fixity)
 261           -> Module
 262           -> [RenamedHsDecl]
 263           -> TcM (TcEnv, PersistentCompilerState,
 264                   [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
 265
 266 -- tcImports is a slight mis-nomer.
 267 -- It deals with everythign that could be an import:
 268 --      type and class decls
 269 --      interface signatures
 270 --      instance decls
 271 --      rule decls
 272 -- These can occur in source code too, of course
 273
 274 tcImports pcs hst get_fixity this_mod decls
 275   = fixTc (\ ~(unf_env, _, _, _, _) ->
 276           -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
 277           -- which is done lazily [ie failure just drops the pragma
 278           -- without having any global-failure effect].
 279           --
 280           -- unf_env is also used to get the pragama info
 281           -- for imported dfuns and default methods
 282
 283 --      traceTc (text "Tc1")                    `thenNF_Tc_`
 284         tcTyAndClassDecls unf_env tycl_decls    `thenTc` \ env ->
 285         tcSetEnv env                            $
 286
 287                 -- Typecheck the instance decls, includes deriving
 288 --      traceTc (text "Tc2")    `thenNF_Tc_`
 289         tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
 290                      hst unf_env get_fixity this_mod
 291                      decls                      `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
 292         tcSetInstEnv inst_env                   $
 293
 294         -- Interface type signatures
 295         -- We tie a knot so that the Ids read out of interfaces are in scope
 296         --   when we read their pragmas.
 297         -- What we rely on is that pragmas are typechecked lazily; if
 298         --   any type errors are found (ie there's an inconsistency)
 299         --   we silently discard the pragma
 300 --      traceTc (text "Tc3")                    `thenNF_Tc_`
 301         tcInterfaceSigs unf_env tycl_decls      `thenTc` \ sig_ids ->
 302         tcExtendGlobalValEnv sig_ids            $
 303
 304
 305         tcIfaceRules (pcs_rules pcs) this_mod iface_rules       `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
 306
 307         tcGetEnv                                                `thenTc` \ unf_env ->
 308         let
 309             imported_things = filter (not . isLocalThing this_mod) (nameEnvElts (getTcGEnv unf_env))
 310
 311             new_pte :: PackageTypeEnv
 312             new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
 313
 314             new_pcs :: PersistentCompilerState
 315             new_pcs = pcs { pcs_PTE   = new_pte,
 316                             pcs_insts = new_pcs_insts,
 317                             pcs_rules = new_pcs_rules
 318                       }
 319         in
 320         returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
 321     )
 322   where
 323     tycl_decls  = [d | TyClD d <- decls]
 324     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{Dumping output}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 printTcDump dflags Nothing = return ()
 335 printTcDump dflags (Just (_, results))
 336   = do dumpIfSet_dyn dflags Opt_D_dump_types
 337                      "Type signatures" (dump_sigs results)
 338        dumpIfSet_dyn dflags Opt_D_dump_tc
 339                      "Typechecked" (dump_tc results)
 340
 341 dump_tc results
 342   = vcat [ppr (tc_binds results),
 343           pp_rules (tc_rules results),
 344           ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
 345     ]
 346
 347 dump_sigs results       -- Print type signatures
 348   =     -- Convert to HsType so that we get source-language style printing
 349         -- And sort by RdrName
 350     vcat $ map ppr_sig $ sortLt lt_sig $
 351     [ (toRdrName id, toHsType (idType id))
 352     | AnId id <- nameEnvElts (tc_env results),
 353       want_sig id
 354     ]
 355   where
 356     lt_sig (n1,_) (n2,_) = n1 < n2
 357     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
 358
 359     want_sig id | opt_PprStyle_Debug = True
 360                 | otherwise          = True     -- For now
 361
 362 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
 363                            vcat (map ppr_gen_tycon tcs),
 364                            ptext SLIT("#-}")
 365                      ]
 366
 367 -- x&y are now Id's, not CoreExpr's
 368 ppr_gen_tycon tycon
 369   | Just ep <- tyConGenInfo tycon
 370   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
 371
 372   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 373
 374 ppr_ep (EP from to)
 375   = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
 376            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
 377            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
 378     ]
 379   where
 380     (_,from_tau) = splitForAllTys (idType from)
 381
 382 pp_rules [] = empty
 383 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
 384                     nest 4 (vcat (map ppr rs)),
 385                     ptext SLIT("#-}")]
 386 \end{code}