ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcTyDecls]{Typecheck algebraic datatypes and type synonyms}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcTyDecls ( tcTyDecls ) where
  10
  11 import TcMonad          -- typechecking monad machinery
  12 import AbsSyn           -- the stuff being typechecked
  13
  14 import AbsUniType       ( applyTyCon, mkDataTyCon, mkSynonymTyCon,
  15                           getUniDataTyCon, isUnboxedDataType,
  16                           isTyVarTemplateTy, cmpUniTypeMaybeList,
  17                           pprMaybeTy
  18                         )
  19 import CE               ( lookupCE, CE(..) )
  20 import CmdLineOpts      ( GlobalSwitch(..) )
  21 import E                ( getE_TCE, getE_CE, plusGVE, nullGVE, GVE(..), E )
  22 import ErrUtils         ( addShortErrLocLine )
  23 import Errors           ( confusedNameErr, specDataNoSpecErr, specDataUnboxedErr )
  24 import FiniteMap        ( FiniteMap, emptyFM, plusFM, singletonFM )
  25 import IdInfo           ( SpecEnv, mkSpecEnv, SpecInfo(..) )
  26 import Pretty
  27 import SpecTyFuns       ( specialiseConstrTys )
  28 import TCE              -- ( nullTCE, unitTCE, lookupTCE, plusTCE, TCE(..), UniqFM )
  29 import TVE              ( mkTVE, TVE(..) )
  30 import TcConDecls       ( tcConDecls )
  31 import TcMonoType       ( tcMonoType )
  32 import TcPragmas        ( tcDataPragmas, tcTypePragmas )
  33 import Util
  34 \end{code}
  35
  36 We consult the @CE@/@TCE@ arguments {\em only} to build knots!
  37
  38 The resulting @TCE@ has info about the type constructors in it; the
  39 @GVE@ has info about their data constructors.
  40
  41 \begin{code}
  42 tcTyDecls :: E
  43           -> (Name -> Bool)                     -- given Name, is it an abstract synonym?
  44           -> (Name -> [RenamedDataTypeSig])     -- given Name, get specialisation pragmas
  45           -> [RenamedTyDecl]
  46           -> Baby_TcM (TCE, GVE,
  47                        FiniteMap TyCon [(Bool, [Maybe UniType])])
  48                                                 -- specialisations:
  49                                                 --   True  => imported data types i.e. from interface file
  50                                                 --   False => local data types i.e. requsted by source pragmas
  51
  52 tcTyDecls e _ _ [] = returnB_Tc (nullTCE, nullGVE, emptyFM)
  53
  54 tcTyDecls e is_abs_syn get_spec_sigs (tyd: tyds)
  55   = tc_decl   tyd           `thenB_Tc` \ (tce1, gve1, specs1) ->
  56     tcTyDecls e is_abs_syn get_spec_sigs tyds
  57                             `thenB_Tc` \ (tce2, gve2, specs2) ->
  58     let
  59         tce3   = tce1 `plusTCE` tce2
  60         gve3   = gve1 `plusGVE` gve2
  61         specs3 = specs1 `plusFM` specs2
  62     in
  63     returnB_Tc (tce3, gve3, specs3)
  64   where
  65     rec_ce  = getE_CE  e
  66     rec_tce = getE_TCE e
  67
  68     -- continued...
  69 \end{code}
  70
  71 We don't need to substitute here, because the @TCE@s
  72 (which are at the top level) cannot contain free type variables.
  73
  74 Gather relevant info:
  75 \begin{code}
  76     tc_decl (TyData context name@(PreludeTyCon uniq full_name arity True{-"data"-})
  77                     tyvars con_decls derivings pragmas src_loc)
  78                             -- ToDo: context
  79       = tc_data_decl uniq name full_name arity tyvars con_decls
  80                      derivings pragmas src_loc
  81
  82     tc_decl (TyData context name@(OtherTyCon uniq full_name arity True{-"data"-} _)
  83                     tyvars con_decls derivings pragmas src_loc)
  84                             -- ToDo: context
  85       = tc_data_decl uniq name full_name arity tyvars con_decls
  86                      derivings pragmas src_loc
  87
  88     tc_decl (TyData _ bad_name _ _ _ _ src_loc)
  89       = failB_Tc (confusedNameErr "Bad name on a datatype constructor (a Prelude name?)"
  90                     bad_name src_loc)
  91
  92     tc_decl (TySynonym name@(PreludeTyCon uniq full_name arity False{-"type"-})
  93                         tyvars mono_ty pragmas src_loc)
  94       = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
  95
  96     tc_decl (TySynonym name@(OtherTyCon uniq full_name arity False{-"type"-} _)
  97                         tyvars mono_ty pragmas src_loc)
  98       = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
  99
 100     tc_decl (TySynonym bad_name _ _ _ src_loc)
 101       = failB_Tc (confusedNameErr "Bad name on a type-synonym constructor (a Prelude name?)"
 102                     bad_name src_loc)
 103 \end{code}
 104
 105 Real work for @data@ declarations:
 106 \begin{code}
 107     tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc
 108       = addSrcLocB_Tc src_loc (
 109         let
 110             (tve, new_tyvars, _) = mkTVE tyvars
 111             rec_tycon            = lookupTCE rec_tce name
 112                 -- We know the lookup will succeed, because we are just
 113                 -- about to put it in the outgoing TCE!
 114
 115             spec_sigs = get_spec_sigs name
 116         in
 117         tcSpecDataSigs rec_tce spec_sigs []     `thenB_Tc` \ user_spec_infos ->
 118
 119         recoverIgnoreErrorsB_Tc ([], []) (
 120             tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas
 121         )               `thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) ->
 122         let
 123             (condecls_to_use, ignore_condecl_errors_if_pragma)
 124               = if null pragma_con_decls then
 125                     (con_decls, id)
 126                 else
 127                     if null con_decls
 128                     then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE)
 129                     else panic "tcTyDecls:data: user and pragma condecls!"
 130
 131             (imported_specs, specinfos_to_use)
 132               = if null pragma_spec_infos then
 133                     (False, user_spec_infos)
 134                 else
 135                     if null user_spec_infos
 136                     then (True, pragma_spec_infos)
 137                     else panic "tcTyDecls:data: user and pragma specinfos!"
 138
 139             specenv_to_use = mkSpecEnv specinfos_to_use
 140         in
 141         ignore_condecl_errors_if_pragma
 142         (tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use)
 143                                                         `thenB_Tc` \ gve ->
 144         let
 145             condecls = map snd gve
 146
 147             derived_classes = map (lookupCE rec_ce) derivings
 148
 149             new_tycon
 150               = mkDataTyCon uniq
 151                             full_name arity new_tyvars condecls
 152                             derived_classes
 153                             (null pragma_con_decls)
 154                             -- if constrs are from pragma we are *abstract*
 155
 156             spec_list
 157               = [(imported_specs, maybe_tys) | (SpecInfo maybe_tys _ _) <- specinfos_to_use]
 158
 159             spec_map
 160               = if null spec_list then
 161                     emptyFM
 162                 else
 163                     singletonFM rec_tycon spec_list
 164         in
 165         returnB_Tc (unitTCE uniq new_tycon, gve, spec_map)
 166             -- It's OK to return pragma condecls in gve, even
 167             -- though some of those names should be "invisible",
 168             -- because the *renamer* is supposed to have dealt with
 169             -- naming/scope issues already.
 170         )
 171 \end{code}
 172
 173 Real work for @type@ (synonym) declarations:
 174 \begin{code}
 175     tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
 176       = addSrcLocB_Tc src_loc (
 177
 178         let (tve, new_tyvars, _) = mkTVE tyvars
 179         in
 180         tcMonoType rec_ce rec_tce tve mono_ty   `thenB_Tc` \ expansion ->
 181         let
 182             -- abstractness info either comes from the interface pragmas
 183             -- (tcTypePragmas) or from a user-pragma in this module
 184             -- (is_abs_syn)
 185             abstract = tcTypePragmas pragmas
 186                     || is_abs_syn name
 187
 188             new_tycon = mkSynonymTyCon uniq full_name
 189                             arity new_tyvars expansion (not abstract)
 190         in
 191         returnB_Tc (unitTCE uniq new_tycon, nullGVE, emptyFM)
 192         )
 193 \end{code}
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Specialisation Signatures for Data Type declarations}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 @tcSpecDataSigs@ checks data type specialisation signatures for
 202 validity, and returns the list of specialisation requests.
 203
 204 \begin{code}
 205 tcSpecDataSigs :: TCE
 206                -> [RenamedDataTypeSig]
 207                -> [(RenamedDataTypeSig,SpecInfo)]
 208                -> Baby_TcM [SpecInfo]
 209
 210 tcSpecDataSigs tce (s:ss) accum
 211   = tc_sig s                    `thenB_Tc` \ info  ->
 212     tcSpecDataSigs tce ss ((s,info):accum)
 213   where
 214     tc_sig (SpecDataSig n ty src_loc)
 215       = addSrcLocB_Tc src_loc (
 216         let
 217             ty_names  = extractMonoTyNames (==) ty
 218             (tve,_,_) = mkTVE ty_names
 219             fake_CE   = panic "tcSpecDataSigs:CE"
 220         in
 221             -- Typecheck specialising type (includes arity check)
 222         tcMonoType fake_CE tce tve ty                   `thenB_Tc` \ tau_ty ->
 223         let
 224             (_,ty_args,_) = getUniDataTyCon tau_ty
 225             is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty
 226         in
 227             -- Check at least one unboxed type in specialisation
 228         checkB_Tc (not (any isUnboxedDataType ty_args))
 229                   (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_`
 230
 231             -- Check all types are unboxed or tyvars
 232             -- (specific boxed types are redundant)
 233         checkB_Tc (not (all is_unboxed_or_tyvar ty_args))
 234                   (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_`
 235
 236         let
 237             maybe_tys     = specialiseConstrTys ty_args
 238         in
 239         returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId"))
 240         )
 241
 242 tcSpecDataSigs tce [] accum
 243   = -- Remove any duplicates from accumulated specinfos
 244     getSwitchCheckerB_Tc                `thenB_Tc` \ sw_chkr ->
 245
 246     (if sw_chkr SpecialiseTrace && not (null duplicates) then
 247          pprTrace "Duplicate SPECIALIZE data pragmas:\n"
 248                   (ppAboves (map specmsg sep_dups))
 249      else id)(
 250
 251     (if sw_chkr SpecialiseTrace && not (null spec_infos) then
 252          pprTrace "Specialising "
 253                   (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"])
 254                         4 (ppAboves (map pp_spec spec_infos)))
 255
 256     else id) (
 257
 258     returnB_Tc (spec_infos)
 259     ))
 260   where
 261     spec_infos = map (snd . head) equiv
 262
 263     equiv      = equivClasses cmp_info accum
 264     duplicates = filter (not . singleton) equiv
 265
 266     cmp_info (_, SpecInfo tys1 _ _) (_, SpecInfo tys2 _ _)
 267       = cmpUniTypeMaybeList tys1 tys2
 268
 269     singleton [_] = True
 270     singleton _   = False
 271
 272     sep_dups = tail (concat (map ((:) Nothing . map Just) duplicates))
 273     specmsg (Just (SpecDataSig _ ty locn, _))
 274       = addShortErrLocLine locn ( \ sty -> ppr sty ty ) PprDebug
 275     specmsg Nothing
 276       = ppStr "***"
 277
 278     ((SpecDataSig name _ _, _):_) = accum
 279     pp_spec (SpecInfo tys _ _) = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- tys]
 280 \end{code}