ghc/compiler/typecheck/TcTyDecls.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[TcTyDecls]{Typecheck type declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcTyDecls (
  10         tcTyDecl,
  11         tcConDecl
  12     ) where
  13
  14 import Ubiq{-uitous-}
  15
  16 import HsSyn            ( TyDecl(..), ConDecl(..), BangType(..), MonoType )
  17 import RnHsSyn          ( RenamedTyDecl(..), RenamedConDecl(..) )
  18
  19 import TcMonoType       ( tcMonoTypeKind, tcMonoType, tcContext )
  20 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass )
  21 import TcMonad
  22 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  23
  24 import Id               ( mkDataCon, StrictnessMark(..) )
  25 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  26 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  27 import Name             ( getNameFullName, Name(..) )
  28 import Pretty
  29 import TyCon            ( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon )
  30 import Type             ( getTypeKind )
  31 import TyVar            ( getTyVarKind )
  32 import Util             ( panic )
  33
  34 \end{code}
  35
  36 \begin{code}
  37 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  38 \end{code}
  39
  40 Type synonym decls
  41 ~~~~~~~~~~~~~~~~~~
  42
  43 \begin{code}
  44 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  45   = tcAddSrcLoc src_loc $
  46     tcAddErrCtxt (tySynCtxt tycon_name) $
  47
  48         -- Look up the pieces
  49     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  rec_tycon) ->
  50     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  51
  52         -- Look at the rhs
  53     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  54
  55         -- Unify tycon kind with (k1->...->kn->rhs)
  56     unifyKind tycon_kind
  57         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  58                                                 `thenTc_`
  59     let
  60         -- Construct the tycon
  61         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  62         result_kind      = getTypeKind rhs_ty
  63         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
  64
  65         tycon = mkSynTyCon (getItsUnique tycon_name)
  66                            (getNameFullName tycon_name)
  67                            final_tycon_kind
  68                            (length tyvar_names)
  69                            rec_tyvars
  70                            rhs_ty
  71     in
  72     returnTc tycon
  73 \end{code}
  74
  75 Algebraic data and newtype decls
  76 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  77
  78 \begin{code}
  79 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
  80   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
  81
  82 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
  83   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
  84
  85
  86 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
  87   = tcAddSrcLoc src_loc $
  88     tcAddErrCtxt (tyDataCtxt tycon_name) $
  89
  90         -- Lookup the pieces
  91     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  rec_tycon) ->
  92     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  93     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
  94
  95         -- Typecheck the context
  96     tcContext context                           `thenTc` \ ctxt ->
  97
  98         -- Unify tycon kind with (k1->...->kn->Type)
  99     unifyKind tycon_kind
 100         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 101                                                 `thenTc_`
 102         -- Walk the condecls
 103     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 104                                                 `thenTc` \ con_ids ->
 105     let
 106         -- Construct the tycon
 107         final_tycon_kind :: Kind                -- NB not TcKind!
 108         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
 109
 110         tycon = mkDataTyCon (getItsUnique tycon_name)
 111                             final_tycon_kind
 112                             (getNameFullName tycon_name)
 113                             rec_tyvars
 114                             ctxt
 115                             con_ids
 116                             derived_classes
 117                             ConsVisible         -- For now; if constrs are from pragma we are *abstract*
 118                             data_or_new
 119     in
 120     returnTc tycon
 121   where
 122     tc_derivs Nothing   = returnNF_Tc []
 123     tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
 124
 125     tc_deriv name
 126       = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
 127         returnNF_Tc clas
 128 \end{code}
 129
 130
 131 Constructors
 132 ~~~~~~~~~~~~
 133 \begin{code}
 134 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 135
 136 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 137   = tcAddSrcLoc src_loc $
 138     let
 139         (stricts, tys) = sep_bangs btys
 140     in
 141     mapTc tcMonoType tys `thenTc` \ arg_tys ->
 142     let
 143       data_con = mkDataCon (getItsUnique name)
 144                            (getNameFullName name)
 145                            stricts
 146                            tyvars
 147                            [] -- ToDo: ctxt; limited to tyvars in arg_tys
 148                            arg_tys
 149                            tycon
 150                         -- nullSpecEnv
 151     in
 152     returnTc data_con
 153
 154 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 155   = tcAddSrcLoc src_loc $
 156     let
 157         (stricts, tys) = sep_bangs [bty1, bty2]
 158     in
 159     mapTc tcMonoType tys `thenTc` \ arg_tys ->
 160     let
 161       data_con = mkDataCon (getItsUnique op)
 162                            (getNameFullName op)
 163                            stricts
 164                            tyvars
 165                            [] -- ToDo: ctxt
 166                            arg_tys
 167                            tycon
 168                         -- nullSpecEnv
 169     in
 170     returnTc data_con
 171
 172 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 173   = tcAddSrcLoc src_loc $
 174     tcMonoType ty `thenTc` \ arg_ty ->
 175     let
 176       data_con = mkDataCon (getItsUnique name)
 177                            (getNameFullName name)
 178                            [NotMarkedStrict]
 179                            tyvars
 180                            [] -- ToDo: ctxt
 181                            [arg_ty]
 182                            tycon
 183                         -- nullSpecEnv
 184     in
 185     returnTc data_con
 186
 187 tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc)
 188   = panic "tcConDecls:RecConDecl"
 189
 190
 191 sep_bangs btys
 192   = unzip (map sep_bang btys)
 193   where
 194     sep_bang (Banged ty)   = (MarkedStrict, ty)
 195     sep_bang (Unbanged ty) = (NotMarkedStrict, ty)
 196 \end{code}
 197
 198
 199
 200 Errors and contexts
 201 ~~~~~~~~~~~~~~~~~~~
 202 \begin{code}
 203 tySynCtxt tycon_name sty
 204   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 205
 206 tyDataCtxt tycon_name sty
 207   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 208
 209 tyNewCtxt tycon_name sty
 210   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 211 \end{code}