-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
-
----------------------------------------
-rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-
-rnHsType doc (HsForAllTy Nothing ctxt ty)
- -- Implicit quantifiction in 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
-
-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 | 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
-
-rnHsType doc (HsTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (HsTyVar tyvar', unitFV tyvar')
-
-rnHsType doc (HsFunTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- -- Might find a for-all as the arg of a function type
- rnHsType 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 (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (HsListTy ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsListTy 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 (HsTupleTy (HsTupCon _ boxity) tys)
- -- Don't do lookupOccRn, because this is built-in syntax
- -- so it doesn't need to be in scope
- = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
- returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
- where
- n' = tupleTyCon_name boxity (length tys)
-
-
-rnHsType doc (HsAppTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
- returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (HsPredTy pred)
- = rnPred doc pred `thenRn` \ (pred', fvs) ->
- returnRn (HsPredTy pred', fvs)
-
-rnHsType doc (HsUsgForAllTy uv_rdr ty)
- = bindUVarRn doc uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsUsgForAllTy uv_name ty',
- fvs )
-
-rnHsType doc (HsUsgTy usg ty)
- = newUsg usg `thenRn` \ (usg', usg_fvs) ->
- rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
- -- A for-all can occur inside a usage annotation
- returnRn (HsUsgTy usg' ty',
- usg_fvs `plusFV` ty_fvs)
- where
- newUsg usg = case usg of
- HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
- HsUsMany -> returnRn (HsUsMany, emptyFVs)
- HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
- returnRn (HsUsVar uv_name, emptyFVs)
-
-rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
-\end{code}
-
-\begin{code}
--- We use lookupOcc here because this is interface file only stuff
--- and we need the workers...
-rnHsTupCon (HsTupCon n boxity)
- = lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity, unitFV n')
-
-rnHsTupConWkr (HsTupCon n boxity)
- -- Tuple construtors are for the *worker* of the tuple
- -- Going direct saves needless messing about
- = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
- returnRn (HsTupCon n' boxity, unitFV n')
-\end{code}
-
-\begin{code}
--- 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)
-\end{code}
-
-\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
-rnContext doc ctxt
- = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
- let
- (_, dups) = removeDupsEq theta
- -- We only have equality, not ordering
- in
- -- Check for duplicate assertions
- -- If this isn't an error, then it ought to be:
- mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
- returnRn (theta, plusFVs fvs_s)
- where
- --Someone discovered that @CCallable@ and @CReturnable@
- -- could be used in contexts such as:
- -- foo :: CCallable a => a -> PrimIO Int
- -- Doing this utterly wrecks the whole point of introducing these
- -- classes so we specifically check that this isn't being done.
- rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
- checkRn (not (bad_pred pred'))
- (naughtyCCallContextErr pred') `thenRn_`
- returnRn (pred', fvs)
-
- bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
- bad_pred other = False
-
-
-rnPred doc (HsPClass clas tys)
- = lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
-
-rnPred doc (HsPIParam n ty)
- = getIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (HsPIParam name ty', fvs)
-\end{code}
-
-\begin{code}
-rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)