-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
- -- rnHsSigType is used for source-language type signatures,
- -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
- = rnHsPolyType (text "the type signature for" <+> doc_str) ty
-
----------------------------------------
-rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
--- rnHsPolyType is prepared to see a for-all; rnHsType is not
--- The former is called for the top level of type sigs and function args.
-
----------------------------------------
-rnHsPolyType 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 doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
- rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
-
-rnHsPolyType 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 | p <- ctxt,
- ty <- tys_of_pred p,
- tv <- extractHsTyRdrTyVars ty]
- tys_of_pred (HsPClass clas tys) = tys
- tys_of_pred (HsPIParam n ty) = [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 doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
- rnForAll doc forall_tyvars ctxt' tau
-
-rnHsPolyType doc other_ty = rnHsType doc other_ty
-
-
--- 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 doc forall_tyvars tau_vars ctxt ty
- = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
- returnRn (catMaybes maybe_ctxt')
- -- Remove problem ones, to avoid duplicate error message.
-
-checkPred doc forall_tyvars ty p@(HsPClass clas tys)
- | not_univ = failWithRn Nothing (univErr doc p ty)
- | otherwise = returnRn (Just p)
- where
- ct_vars = extractHsTysRdrTyVars tys
- not_univ = -- At least one of the tyvars in each constraint must
- -- be universally quantified. This restriction isn't in Hugs
- not (any (`elem` forall_tyvars) ct_vars)
-checkPred doc forall_tyvars ty p@(HsPIParam _ _)
- = returnRn (Just p)
-
-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 (Just new_tyvars) new_ctxt new_ty,
- cxt_fvs `plusFV` ty_fvs)
-
----------------------------------------
-rnHsType doc ty@(HsForAllTy _ _ inner_ty)
- = addWarnRn (unexpectedForAllTy ty) `thenRn_`
- rnHsPolyType doc ty
-
-rnHsType doc (MonoTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (MonoTyVar tyvar', unitFV tyvar')
-
-rnHsType doc (MonoFunTy ty1 ty2)
- = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
- -- Might find a for-all as the arg of a function type
- rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
- -- Or as the result. This happens when reading Prelude.hi
- -- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoListTy ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
--- Unboxed tuples are allowed to have poly-typed arguments. These
--- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (MonoTupleTy tys boxed)
- = (if boxed
- then mapFvRn (rnHsType doc) tys
- else mapFvRn (rnHsPolyType 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 (MonoIParamTy n ty)
- = getIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoIParamTy name ty', fvs)
-
-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) ->
- rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
- -- A for-all can occur inside a usage annotation
- 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
+ = ASSERT( null (unLoc context) )
+ do { tycon' <- lookupLocatedTopBndrRn 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) }
+