ghc/compiler/typecheck/TcModule.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcModule (
  10         tcModule,
  11
  12         -- to make the interface self-sufficient...
  13         Module, Bag, CE(..), E, Binds, FixityDecl, Expr, InPat,
  14         RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, TcResult,
  15         Name, ProtoName, SrcLoc, Subst, TCE(..), UniqFM,
  16         Error(..), Pretty(..), PprStyle, PrettyRep, InstInfo
  17     ) where
  18
  19 import TcMonad          -- typechecking monad machinery
  20 import AbsSyn           -- the stuff being typechecked
  21
  22 -- OLD:
  23 --import AbsPrel        ( stringTy,
  24 --                        eqStringId, neStringId, ltStringId,
  25 --                        leStringId, geStringId, gtStringId,
  26 --                        maxStringId, minStringId, tagCmpStringId,
  27 --                        dfunEqStringId, dfunOrdStringId,
  28 --                        pRELUDE_CORE
  29 --                        IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
  30 --                      )
  31 --#if USE_ATTACK_PRAGMAS
  32 --import PrelVals       ( string_cmp_id ) -- shouldn't even be visible, really
  33 --#endif
  34 import BackSubst        ( applyTcSubstToBinds )
  35 import Bag              ( unionBags, bagToList, emptyBag, listToBag )
  36 import CE               ( nullCE, checkClassCycles, lookupCE, CE(..) )
  37 import CmdLineOpts      ( GlobalSwitch(..) )
  38 import E
  39 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  40 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  41 import InstEnv
  42 import LIE              ( unMkLIE, plusLIE, LIE )
  43 import Name             ( Name(..) )
  44 import RenameAuxFuns    ( GlobalNameFuns(..), GlobalNameFun(..), ProtoName, Maybe )
  45 import SrcLoc           ( mkBuiltinSrcLoc, SrcLoc )
  46 import TCE              ( checkTypeCycles, TCE(..), UniqFM )
  47 import TcBinds          ( tcTopBindsAndThen )
  48 import TcClassDcl       ( tcClassDecls1, tcClassDecls2, ClassInfo )
  49 import TcDefaults       ( tcDefaults )
  50 import TcDeriv          ( tcDeriving )
  51 import TcIfaceSig       ( tcInterfaceSigs )
  52 import TcInstDcls       ( tcInstDecls1, tcInstDecls2, tcSpecInstSigs, buildInstanceEnvs, InstInfo(..) )
  53 import TcSimplify       ( tcSimplifyTop )
  54 import TcTyDecls        ( tcTyDecls )
  55 import Unique           -- some ClassKey stuff
  56 import UniqFM           ( emptyUFM ) -- profiling, pragmas only
  57 import Util
  58
  59 import Pretty           -- Debugging
  60 \end{code}
  61
  62 \begin{code}
  63 tcModule :: E                           -- initial typechecker environment
  64          -> GlobalNameFuns              -- final renamer info (to do derivings)
  65          -> RenamedModule               -- input
  66          -> TcM ((TypecheckedBinds,     -- binds from class decls; does NOT
  67                                         -- include default-methods bindings
  68                   TypecheckedBinds,     -- binds from instance decls; INCLUDES
  69                                         -- class default-methods binds
  70                   TypecheckedBinds,     -- binds from value decls
  71                   [(Inst, TypecheckedExpr)]),
  72
  73                  ([RenamedFixityDecl],  -- things for the interface generator
  74                   [Id],                 -- to look at...
  75                   CE,
  76                   TCE,
  77                   Bag InstInfo),
  78
  79                  FiniteMap TyCon [[Maybe UniType]],
  80                                         -- source tycon specialisation requests
  81
  82 --UNUSED:        E,                     -- environment of total accumulated info
  83                  E,                     -- environment of info due to this module only
  84                  PprStyle -> Pretty)    -- -ddump-deriving info (passed upwards)
  85
  86 tcModule e1 renamer_name_funs
  87         (Module mod_name exports imports_should_be_empty fixities
  88              tydecls ty_sigs classdecls instdecls specinst_sigs
  89              default_decls valdecls sigs src_loc)
  90
  91   = addSrcLocTc src_loc (       -- record where we're starting
  92
  93         -- Tie the knot for inteface-file value declaration signatures
  94         -- This info is only used inside the knot for type-checking the
  95         -- pragmas, which is done lazily [ie failure just drops the pragma
  96         -- without having any global-failure effect].
  97
  98     fixTc (\ ~(rec_gve_sigs, _, _, _, _, _, _, _, _, _) ->
  99     let
 100         e2 = plusE_GVE e1 rec_gve_sigs
 101     in
 102
 103         -- The knot for instance information.  This isn't used at all
 104         -- till we type-check value declarations.
 105         fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _, _, _, _) ->
 106
 107              -- The knot for TyCons and Classes
 108             fixTc ( \ ~(_, rec_tce, rec_ce, rec_datacons_gve, rec_ops_gve, _, _) ->
 109                 let
 110                     e3 = e2
 111                          `plusE_GVE` rec_datacons_gve
 112                          `plusE_GVE` rec_ops_gve
 113                          `plusE_TCE` rec_tce
 114                          `plusE_CE`  rec_ce
 115                 in
 116                     -- DO THE TYPE DECLS
 117                     -- Including the pragmas: {-# ABSTRACT TypeSyn #-}
 118                     --                        {-# SPECIALIZE data DataType ... #-}
 119                 let
 120                     (absty_sigs, specdata_sigs) = partition is_absty_sig ty_sigs
 121                     is_absty_sig (AbstractTypeSig _ _) = True
 122                     is_absty_sig (SpecDataSig _ _ _)   = False
 123
 124                     is_abs_syn :: Name -> Bool  -- a lookup fn for abs synonyms
 125                     is_abs_syn n
 126                       = n `is_elem` [ tc | (AbstractTypeSig tc _) <- absty_sigs ]
 127                       where
 128                         is_elem = isIn "tcModule"
 129
 130                     get_spec_sigs :: Name -> [RenamedDataTypeSig]
 131                     get_spec_sigs n
 132                       = [ sig | sig@(SpecDataSig tc _ _) <- specdata_sigs, n == tc]
 133                 in
 134                 babyTcMtoTcM (tcTyDecls e3 is_abs_syn get_spec_sigs tydecls)
 135                         `thenTc` \ (tce, datacons_gve, tycon_specs) ->
 136
 137                     -- DO THE CLASS DECLS
 138                 tcClassDecls1 e3 rec_inst_mapper classdecls
 139                         `thenTc` \ (class_info, ce, ops_gve) ->
 140
 141                     -- End of TyCon/Class knot
 142                     -- Augment whatever TCE/GVE/CE stuff was in orig_e
 143                 returnTc (e3, tce, ce, datacons_gve, ops_gve, class_info, tycon_specs)
 144
 145                    -- End of inner fixTc
 146             )   `thenTc` ( \ (e3, tce_here, ce_here, _, _, class_info, tycon_specs) ->
 147                              -- The "here" things are the extra decls defined in this
 148                              -- module or its imports; but not including whatever was
 149                              -- in the incoming e.
 150
 151                     -- Grab completed tce/ce and check for type/class cycles
 152                     -- The tce/ce are now stable and lookable-at, with the
 153                     -- exception of the instance information inside classes
 154             let
 155                 ce3  = getE_CE e3
 156                 tce3 = getE_TCE e3
 157             in
 158             checkMaybeErrTc (checkTypeCycles tce3) id    `thenTc_`
 159             checkMaybeErrTc (checkClassCycles ce3) id    `thenTc_`
 160
 161                     -- Now instance declarations
 162             tcInstDecls1 e3 ce3 tce3 instdecls          `thenNF_Tc` \ decl_inst_info ->
 163
 164                     -- Handle "derived" instances; note that we only do derivings
 165                     -- for things in this module; we ignore deriving decls from
 166                     -- interfaces! We pass fixities, because they may be used in
 167                     -- doing Text.
 168
 169             tcDeriving mod_name renamer_name_funs decl_inst_info tce3 fixities
 170                     `thenTc` \ (deriv_inst_info, extra_deriv_binds, ddump_deriv) ->
 171
 172             let
 173                 inst_info = deriv_inst_info `unionBags` decl_inst_info
 174             in
 175                     -- Handle specialise instance pragmas
 176 --          getSwitchCheckerTc                  `thenNF_Tc` \ sw_chkr ->
 177 --          (if sw_chkr GlasgowExts then
 178                  tcSpecInstSigs e3 ce3 tce3 inst_info specinst_sigs
 179 --           else
 180 --               returnTc emptyBag)
 181                                                 `thenTc` \ spec_inst_info ->
 182             let
 183                 full_inst_info = inst_info `unionBags` spec_inst_info
 184             in
 185                     -- OK, now do the inst-mapper stuff
 186             buildInstanceEnvs full_inst_info    `thenTc` \ all_insts_mapper ->
 187
 188             returnTc (all_insts_mapper, e3, ce_here, tce_here, class_info, tycon_specs,
 189                       full_inst_info, extra_deriv_binds, ddump_deriv)
 190
 191                     -- End of outer fixTc
 192         )) `thenTc` ( \ (_, e3, ce_here, tce_here, class_info, tycon_specs,
 193                         full_inst_info, extra_deriv_binds, ddump_deriv) ->
 194
 195     -- Default declarations
 196     tcDefaults e3 default_decls `thenTc` \ defaulting_tys ->
 197     setDefaultingTys defaulting_tys ( -- for the iface sigs...
 198
 199     -- Interface type signatures
 200
 201     -- We tie a knot so that the Ids read out of interfaces are in scope
 202     --   when we read their pragmas.
 203     -- What we rely on is that pragmas are typechecked lazily; if
 204     --   any type errors are found (ie there's an inconsistency)
 205     --   we silently discard the pragma
 206
 207     babyTcMtoTcM (tcInterfaceSigs e3 sigs)      `thenTc` \ gve_sigs ->
 208
 209     returnTc (gve_sigs, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
 210               full_inst_info, extra_deriv_binds, ddump_deriv)
 211
 212     -- End of extremely outer fixTc
 213     ))) `thenTc` \ (_, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
 214                     full_inst_info, extra_deriv_binds, ddump_deriv) ->
 215
 216     setDefaultingTys defaulting_tys ( -- to the end...
 217
 218         -- Value declarations next.
 219         -- We also typecheck any extra binds that came out of the "deriving" process
 220         -- Nota bene
 221     tcTopBindsAndThen
 222         e3
 223         (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
 224         (valdecls `ThenBinds` extra_deriv_binds)
 225         (\ e4 ->
 226                 -- Second pass over instance declarations,
 227                 -- to compile the bindings themselves.
 228             tcInstDecls2  e4 full_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
 229             tcClassDecls2 e4 class_info     `thenNF_Tc` \ (lie_clasdecls, class_binds) ->
 230             returnTc ( (EmptyBinds, (inst_binds, class_binds, e4)),
 231                        lie_instdecls `plusLIE` lie_clasdecls,
 232                        () )
 233         )
 234
 235         `thenTc` \ ((val_binds, (inst_binds, class_binds, e4)), lie_alldecls, _) ->
 236
 237         -- Deal with constant or ambiguous InstIds.  How could
 238         -- there be ambiguous ones?  They can only arise if a
 239         -- top-level decl falls under the monomorphism
 240         -- restriction, and no subsequent decl instantiates its
 241         -- type.  (Usually, ambiguous type variables are resolved
 242         -- during the generalisation step.)
 243
 244     tcSimplifyTop (unMkLIE lie_alldecls)    `thenTc` \ const_inst_binds ->
 245
 246         -- Backsubstitution.  Monomorphic top-level decls may have
 247         -- been instantiated by subsequent decls, and the final
 248         -- simplification step may have instantiated some
 249         -- ambiguous types.  So, sadly, we need to back-substitute
 250         -- over the whole bunch of bindings.
 251
 252     applyTcSubstToBinds val_binds           `thenNF_Tc` \ val_binds' ->
 253     applyTcSubstToBinds inst_binds          `thenNF_Tc` \ inst_binds' ->
 254     applyTcSubstToBinds class_binds         `thenNF_Tc` \ class_binds' ->
 255
 256         -- ToDo: probably need to back-substitute over all
 257         -- stuff in 'e4'; we do so here over the Ids,
 258         -- which is probably enough.  WDP 95/06
 259     mapNF_Tc applyTcSubstToId (getE_GlobalVals e4)
 260                                             `thenNF_Tc` \ if_global_ids ->
 261
 262         -- FINISHED AT LAST
 263     returnTc (
 264         (class_binds', inst_binds', val_binds', const_inst_binds),
 265
 266              -- the next collection is just for mkInterface
 267         (fixities, if_global_ids, ce_here, tce_here, full_inst_info),
 268
 269         tycon_specs,
 270
 271 --UNUSED: e4,
 272
 273           -- and... TCE needed for code generation; rest needed for interpreter.
 274           -- ToDo: still wrong: needs isLocallyDeclared run over everything
 275         mkE tce_here {-gve_here lve-} ce_here,
 276              -- NB: interpreter would probably need the gve_here stuff
 277         ddump_deriv
 278     )))
 279 \end{code}