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         mkDataBinds
  13     ) where
  14
  15 import Ubiq{-uitous-}
  16
  17 import HsSyn            ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
  18                           Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
  19                           HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo,
  20                           PolyType, Fake, InPat,
  21                           Bind(..), MonoBinds(..), Sig,
  22                           MonoType )
  23 import RnHsSyn          ( RenamedTyDecl(..), RenamedConDecl(..),
  24                           RnName{-instance Outputable-}
  25                         )
  26 import TcHsSyn          ( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) )
  27
  28 import Inst             ( newDicts, InstOrigin(..), Inst )
  29 import TcMonoType       ( tcMonoTypeKind, tcMonoType, tcContext )
  30 import TcType           ( tcInstTyVars, tcInstType, tcInstId )
  31 import TcEnv            ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
  32                           tcLookupClassByKey,
  33                           newLocalId, newLocalIds
  34                         )
  35 import TcMonad
  36 import TcKind           ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
  37
  38 import Class            ( GenClass{-instance Eq-} )
  39 import Id               ( mkDataCon, dataConSig, mkRecordSelId,
  40                           dataConFieldLabels, dataConStrictMarks,
  41                           StrictnessMark(..),
  42                           GenId{-instance NamedThing-}
  43                         )
  44 import FieldLabel
  45 import Kind             ( Kind, mkArrowKind, mkBoxedTypeKind )
  46 import SpecEnv          ( SpecEnv(..), nullSpecEnv )
  47 import Name             ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
  48                           Name{-instance Ord3-}
  49                         )
  50 import Pretty
  51 import TyCon            ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
  52                           tyConDataCons )
  53 import Type             ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy,
  54                           applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
  55                           splitFunTy, mkTyVarTy, getTyVar_maybe
  56                         )
  57 import TyVar            ( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
  58 import Unique           ( Unique {- instance Eq -}, dataClassKey )
  59 import UniqSet          ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
  60 import Util             ( equivClasses, zipEqual, panic, assertPanic )
  61 \end{code}
  62
  63 \begin{code}
  64 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
  65 \end{code}
  66
  67 Type synonym decls
  68 ~~~~~~~~~~~~~~~~~~
  69
  70 \begin{code}
  71 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
  72   = tcAddSrcLoc src_loc $
  73     tcAddErrCtxt (tySynCtxt tycon_name) $
  74
  75         -- Look up the pieces
  76     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind,  _, rec_tycon) ->
  77     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
  78
  79         -- Look at the rhs
  80     tcMonoTypeKind rhs                          `thenTc` \ (rhs_kind, rhs_ty) ->
  81
  82         -- Unify tycon kind with (k1->...->kn->rhs)
  83     unifyKind tycon_kind
  84         (foldr mkTcArrowKind rhs_kind tyvar_kinds)
  85                                                 `thenTc_`
  86     let
  87         -- Getting the TyCon's kind is a bit of a nuisance.  We can't use the tycon_kind,
  88         -- because that's a TcKind and may not yet be fully unified with other kinds.
  89         -- We could have augmented the tycon environment with a knot-tied kind,
  90         -- but the simplest thing to do seems to be to get the Kind by (lazily)
  91         -- looking at the tyvars and rhs_ty.
  92         result_kind, final_tycon_kind :: Kind   -- NB not TcKind!
  93         result_kind      = getTypeKind rhs_ty
  94         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
  95
  96         -- Construct the tycon
  97         tycon = mkSynTyCon (getName tycon_name)
  98                            final_tycon_kind
  99                            (length tyvar_names)
 100                            rec_tyvars
 101                            rhs_ty
 102     in
 103     returnTc tycon
 104 \end{code}
 105
 106 Algebraic data and newtype decls
 107 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 108
 109 \begin{code}
 110 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
 111   = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
 112
 113 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
 114   = tcTyDataOrNew NewType  context tycon_name tyvar_names con_decl  derivings pragmas src_loc
 115
 116
 117 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
 118   = tcAddSrcLoc src_loc $
 119     tcAddErrCtxt (tyDataCtxt tycon_name) $
 120
 121         -- Lookup the pieces
 122     tcLookupTyCon tycon_name                    `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
 123     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 124     tc_derivs derivings                         `thenNF_Tc` \ derived_classes ->
 125
 126         -- Typecheck the context
 127     tcContext context                           `thenTc` \ ctxt ->
 128
 129         -- Unify tycon kind with (k1->...->kn->Type)
 130     unifyKind tycon_kind
 131         (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
 132                                                 `thenTc_`
 133
 134         -- Walk the condecls
 135     mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
 136                                                 `thenTc` \ con_ids ->
 137     let
 138         -- Construct the tycon
 139         final_tycon_kind :: Kind                -- NB not TcKind!
 140         final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
 141
 142         tycon = mkDataTyCon (getName tycon_name)
 143                             final_tycon_kind
 144                             rec_tyvars
 145                             ctxt
 146                             con_ids
 147                             derived_classes
 148                             data_or_new
 149     in
 150     returnTc tycon
 151
 152 tc_derivs Nothing   = returnNF_Tc []
 153 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
 154
 155 tc_deriv name
 156   = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
 157     returnNF_Tc clas
 158 \end{code}
 159
 160 Generating constructor/selector bindings for data declarations
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 162
 163 \begin{code}
 164 mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s)
 165 mkDataBinds tycon
 166   = ASSERT( isDataTyCon tycon )
 167     mapAndUnzipTc mkConstructor data_cons               `thenTc` \ (con_ids, con_binds) ->
 168     mapAndUnzipTc (mkRecordSelector tycon) groups       `thenTc` \ (sel_ids, sel_binds) ->
 169     returnTc (con_ids ++ sel_ids,
 170               SingleBind $ NonRecBind $
 171               foldr AndMonoBinds
 172                     (foldr AndMonoBinds EmptyMonoBinds con_binds)
 173                     con_binds
 174     )
 175   where
 176     data_cons = tyConDataCons tycon
 177     fields = [ (con, field) | con   <- data_cons,
 178                               field <- dataConFieldLabels con
 179              ]
 180
 181         -- groups is list of fields that share a common name
 182     groups = equivClasses cmp_name fields
 183     cmp_name (_, field1) (_, field2)
 184         = fieldLabelName field1 `cmp` fieldLabelName field2
 185 \end{code}
 186
 187 We're going to build a constructor that looks like:
 188
 189         data (Data a, C b) =>  T a b = T1 !a !Int b
 190
 191         T1 = /\ a b ->
 192              \d1::Data a, d2::C b ->
 193              \p q r -> case p of { p ->
 194                        case q of { q ->
 195                        HsCon [a,b,c] [p,q,r]}}
 196
 197 Notice that
 198
 199 * d2 is thrown away --- a context in a data decl is used to make sure
 200   one *could* construct dictionaries at the site the constructor
 201   is used, but the dictionary isn't actually used.
 202
 203 * We have to check that we can construct Data dictionaries for
 204   the types a and Int.  Once we've done that we can throw d1 away too.
 205
 206 * We use (case p of ...) to evaluate p, rather than "seq" because
 207   all that matters is that the arguments are evaluated.  "seq" is
 208   very careful to preserve evaluation order, which we don't need
 209   to be here.
 210
 211 \begin{code}
 212 mkConstructor con_id
 213   | not (isLocallyDefinedName (getName con_id))
 214   = returnTc (con_id, EmptyMonoBinds)
 215
 216   | otherwise   -- It is locally defined
 217   = tcInstId con_id                     `thenNF_Tc` \ (tyvars, theta, tau) ->
 218     newDicts DataDeclOrigin theta       `thenNF_Tc` \ (_, dicts) ->
 219     let
 220         (arg_tys, result_ty) = splitFunTy tau
 221         n_args = length arg_tys
 222     in
 223     newLocalIds (take n_args (repeat SLIT("con"))) arg_tys      `thenNF_Tc` {- \ pre_zonk_args ->
 224     mapNF_Tc zonkId pre_zonk_args   `thenNF_Tc` -} \ args ->
 225
 226         -- Check that all the types of all the strict
 227         -- arguments are in Data.  This is trivially true of everything except
 228         -- type variables, for which we must check the context.
 229     let
 230         strict_marks = dataConStrictMarks con_id
 231         strict_args  = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
 232
 233         data_tyvars = -- The tyvars in the constructor's context that are arguments
 234                       -- to the Data class
 235                       [getTyVar "mkConstructor" ty
 236                       | (clas,ty) <- theta,
 237                         uniqueOf clas == dataClassKey]
 238
 239         check_data arg = case getTyVar_maybe (tcIdType arg) of
 240                            Nothing    -> returnTc ()    -- Not a tyvar, so OK
 241                            Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
 242     in
 243     mapTc check_data strict_args                        `thenTc_`
 244
 245         -- Build the data constructor
 246     let
 247         con_rhs = mkHsTyLam tyvars $
 248                   DictLam dicts $
 249                   mk_pat_match args $
 250                   mk_case strict_args $
 251                   HsCon con_id arg_tys (map HsVar args)
 252
 253         mk_pat_match []         body = body
 254         mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
 255
 256         mk_case [] body = body
 257         mk_case (arg:args) body = HsCase (HsVar arg)
 258                                          [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
 259                                          src_loc
 260
 261         src_loc = nameSrcLoc (getName con_id)
 262     in
 263
 264     returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
 265 \end{code}
 266
 267 We're going to build a record selector that looks like this:
 268
 269         data T a b c = T1 { op :: a, ...}
 270                      | T2 { op :: a, ...}
 271                      | T3
 272
 273         sel :: forall a b c. T a b c -> a
 274         sel = /\ a b c -> \ T1 { sel = x } -> x
 275                             T2 { sel = 2 } -> x
 276
 277 Note that the selector Id itself is used as the field
 278 label; it has to be an Id, you see!
 279
 280 \begin{code}
 281 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
 282   = let
 283         field_ty   = fieldLabelType first_field_label
 284         field_name = fieldLabelName first_field_label
 285         other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
 286         (tyvars, _, _, _) = dataConSig first_con
 287         data_ty  = applyTyCon tycon (mkTyVarTys tyvars)
 288         -- tyvars of first_con may be free in field_ty
 289     in
 290
 291         -- Check that all the fields in the group have the same type
 292         -- This check assumes that all the constructors of a given
 293         -- data type use the same type variables
 294     checkTc (all (eqTy field_ty) other_tys)
 295             (fieldTypeMisMatch field_name)      `thenTc_`
 296
 297         -- Create an Id for the field itself
 298     tcInstTyVars tyvars                 `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
 299     tcInstType tenv field_ty            `thenNF_Tc` \ field_ty' ->
 300     let
 301       data_ty' = applyTyCon tycon tyvar_tys
 302     in
 303     newLocalId SLIT("x") field_ty'      `thenNF_Tc` \ field_id ->
 304     newLocalId SLIT("r") data_ty'       `thenNF_Tc` \ record_id ->
 305
 306         -- Now build the selector
 307     let
 308       selector_ty :: Type
 309       selector_ty  = mkForAllTys tyvars $
 310                      mkFunTy data_ty $
 311                      field_ty
 312
 313       selector_id :: Id
 314       selector_id = mkRecordSelId first_field_label selector_ty
 315
 316         -- HsSyn is dreadfully verbose for defining the selector!
 317       selector_rhs = mkHsTyLam tyvars' $
 318                      HsLam $
 319                      PatMatch (VarPat record_id) $
 320                      SimpleMatch $
 321                      selector_body
 322
 323       selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
 324
 325       mk_match (con_id, field_label)
 326         = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $
 327           SimpleMatch $
 328           HsVar field_id
 329     in
 330     returnTc (selector_id, if isLocallyDefinedName (getName tycon)
 331                            then VarMonoBind (RealId selector_id) selector_rhs
 332                            else EmptyMonoBinds)
 333 \end{code}
 334
 335 Constructors
 336 ~~~~~~~~~~~~
 337 \begin{code}
 338 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
 339
 340 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
 341   = tcDataCon tycon tyvars ctxt name btys src_loc
 342
 343 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
 344   = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
 345
 346 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
 347   = tcAddSrcLoc src_loc $
 348     tcMonoType ty `thenTc` \ arg_ty ->
 349     let
 350       data_con = mkDataCon (getName name)
 351                            [NotMarkedStrict]
 352                            [{- No labelled fields -}]
 353                            tyvars
 354                            ctxt
 355                            [arg_ty]
 356                            tycon
 357                         -- nullSpecEnv
 358     in
 359     returnTc data_con
 360
 361 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
 362   = tcAddSrcLoc src_loc $
 363     mapTc tcField fields        `thenTc` \ field_label_infos_s ->
 364     let
 365       field_label_infos = concat field_label_infos_s
 366       stricts           = [strict | (_, _, strict) <- field_label_infos]
 367       arg_tys           = [ty     | (_, ty, _)     <- field_label_infos]
 368
 369       field_labels      = [ mkFieldLabel (getName name) ty tag
 370                           | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
 371                           ]
 372
 373       data_con = mkDataCon (getName name)
 374                            stricts
 375                            field_labels
 376                            tyvars
 377                            (thinContext arg_tys ctxt)
 378                            arg_tys
 379                            tycon
 380                         -- nullSpecEnv
 381     in
 382     returnTc data_con
 383
 384 tcField (field_label_names, bty)
 385   = tcMonoType (get_ty bty)     `thenTc` \ field_ty ->
 386     returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 387
 388 tcDataCon tycon tyvars ctxt name btys src_loc
 389   = tcAddSrcLoc src_loc $
 390     let
 391         stricts = map get_strictness btys
 392         tys     = map get_ty btys
 393     in
 394     mapTc tcMonoType tys `thenTc` \ arg_tys ->
 395     let
 396       data_con = mkDataCon (getName name)
 397                            stricts
 398                            [{- No field labels -}]
 399                            tyvars
 400                            (thinContext arg_tys ctxt)
 401                            arg_tys
 402                            tycon
 403                         -- nullSpecEnv
 404     in
 405     returnTc data_con
 406
 407 -- The context for a data constructor should be limited to
 408 -- the type variables mentioned in the arg_tys
 409 thinContext arg_tys ctxt
 410   = filter in_arg_tys ctxt
 411   where
 412       arg_tyvars = tyVarsOfTypes arg_tys
 413       in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
 414
 415 get_strictness (Banged ty)   = MarkedStrict
 416 get_strictness (Unbanged ty) = NotMarkedStrict
 417
 418 get_ty (Banged ty)   = ty
 419 get_ty (Unbanged ty) = ty
 420 \end{code}
 421
 422
 423
 424 Errors and contexts
 425 ~~~~~~~~~~~~~~~~~~~
 426 \begin{code}
 427 tySynCtxt tycon_name sty
 428   = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
 429
 430 tyDataCtxt tycon_name sty
 431   = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
 432
 433 tyNewCtxt tycon_name sty
 434   = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
 435
 436 fieldTypeMisMatch field_name sty
 437   = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
 438
 439 missingDataErr tyvar sty
 440   = ppStr "Missing `data' (???)" -- ToDo: improve
 441 \end{code}