-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
- -- rnHsSigType is used for source-language type signatures,
- -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
- = rnHsType (text "the type signature for" <+> doc_str) ty
-
-rnForAll doc forall_tyvars ctxt ty
- = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
- rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
- returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
- cxt_fvs `plusFV` ty_fvs)
-
--- Check that each constraint mentions at least one of the forall'd type variables
--- Since the forall'd type variables are a subset of the free tyvars
--- of the tau-type part, this guarantees that every constraint mentions
--- at least one of the free tyvars in ty
-checkConstraints explicit_forall doc forall_tyvars ctxt ty
- = mapRn check ctxt `thenRn` \ maybe_ctxt' ->
- returnRn (catMaybes maybe_ctxt')
- -- Remove problem ones, to avoid duplicate error message.
- where
- check ct@(_,tys)
- | forall_mentioned = returnRn (Just ct)
- | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty)
- `thenRn_` returnRn Nothing
- where
- forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyRdrTyVars)
- False
- tys
-
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
- -- From source code (no kinds on tyvars)
- -- Given the signature C => T we universally quantify
- -- over FV(T) \ {in-scope-tyvars}
- = getLocalNameEnv `thenRn` \ name_env ->
- let
- mentioned_in_tau = extractHsTyRdrTyVars ty
- forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
- in
- checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
- rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
-
-rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
- -- Explicit quantification.
- -- Check that the forall'd tyvars are a subset of the
- -- free tyvars in the tau-type part
- -- That's only a warning... unless the tyvar is constrained by a
- -- context in which case it's an error
- = let
- mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
- ty <- tys,
- tv <- extractHsTyRdrTyVars ty]
-
- dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
- -- dubious = explicitly quantified but not mentioned in tau type
-
- (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
- -- bad = explicitly quantified and constrained, but not mentioned in tau
- -- warn = explicitly quantified but not mentioned in ctxt or tau
-
- forall_tyvar_names = map getTyVarName forall_tyvars
- in
- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
- mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
- checkConstraints True doc forall_tyvar_names ctxt tau `thenRn` \ ctxt' ->
- rnForAll doc forall_tyvars ctxt' tau
-
-rnHsType doc (MonoTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (MonoTyVar tyvar', unitFV tyvar')
-
-rnHsType doc (MonoFunTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
- returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoListTy ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
-rnHsType doc (MonoTupleTy tys boxed)
- = rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
- where
- tup_con_name = tupleTyCon_name boxed (length tys)
-
-rnHsType doc (MonoTyApp ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
- returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoDictTy clas tys)
- = lookupOccRn clas `thenRn` \ clas' ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
-
-rnHsType doc (MonoUsgForAllTy uv_rdr ty)
- = bindUVarRn doc uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoUsgForAllTy uv_name ty',
- fvs )
-
-rnHsType doc (MonoUsgTy usg ty)
- = newUsg usg `thenRn` \ (usg', usg_fvs) ->
- rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
- returnRn (MonoUsgTy usg' ty',
- usg_fvs `plusFV` ty_fvs)
+rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+ = lookupLocatedTopBndrRn name `thenM` \ name' ->
+ returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+ emptyFVs)
+
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
+ tcdTyVars = tyvars, tcdCons = condecls,
+ tcdKindSig = sig, tcdDerivs = derivs})
+ | is_vanilla -- Normal Haskell data type decl
+ = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
+ -- data type is syntactically illegal
+ bindTyVarsRn data_doc tyvars $ \ tyvars' ->
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; context' <- rnContext data_doc context
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; checkDupNames data_doc con_names
+ ; condecls' <- rnConDecls (unLoc tycon') condecls
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
+ tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
+ tcdDerivs = derivs'},
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs) }
+
+ | otherwise -- GADT
+ = do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
+ ; tyvars' <- bindTyVarsRn data_doc tyvars
+ (\ tyvars' -> return tyvars')
+ -- For GADTs, the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; (derivs', deriv_fvs) <- rn_derivs derivs
+ ; checkDupNames data_doc con_names
+ ; condecls' <- rnConDecls (unLoc tycon') condecls
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
+ tcdDerivs = derivs'},
+ plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
+