- ppr (TySigInfo id tyvars theta tau _ inst _) =
- ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
-
-maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
- -- Search for a particular signature
-maybeSig [] name = Nothing
-maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name
- | name == idName sig_id = Just sig
- | otherwise = maybeSig sigs name
-\end{code}
-
-
-\begin{code}
-tcTySig :: LSig Name -> TcM TcSigInfo
-
-tcTySig (L span (Sig (L _ v) ty))
- = addSrcSpan span $
- tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty ->
- mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig ->
- returnM sig
-
-mkTcSig :: TcId -> TcM TcSigInfo
-mkTcSig poly_id
- = -- Instantiate this type
- -- It's important to do this even though in the error-free case
- -- we could just split the sigma_tc_ty (since the tyvars don't
- -- unified with anything). But in the case of an error, when
- -- the tyvars *do* get unified with something, we want to carry on
- -- typechecking the rest of the program with the function bound
- -- to a pristine type, namely sigma_tc_ty
- tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') ->
-
- getInstLoc SignatureOrigin `thenM` \ inst_loc ->
- newMethod inst_loc poly_id
- (mkTyVarTys tyvars')
- theta' tau' `thenM` \ inst ->
- -- We make a Method even if it's not overloaded; no harm
- -- But do not extend the LIE! We're just making an Id.
-
- getSrcSpanM `thenM` \ src_loc ->
- returnM (TySigInfo { sig_poly_id = poly_id, sig_tvs = tyvars',
- sig_theta = theta', sig_tau = tau',
- sig_mono_id = instToId inst,
- sig_insts = [inst], sig_loc = src_loc })
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Errors and contexts}
-%* *
-%************************************************************************
-
-
-\begin{code}
-hoistForAllTys :: Type -> Type
--- Used for user-written type signatures only
--- Move all the foralls and constraints to the top
--- e.g. T -> forall a. a ==> forall a. T -> a
--- T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int
---
--- Also: eliminate duplicate constraints. These can show up
--- when hoisting constraints, notably implicit parameters.
---
--- We want to 'look through' type synonyms when doing this
--- so it's better done on the Type than the HsType
-
-hoistForAllTys ty
- = let
- no_shadow_ty = deShadowTy ty
- -- Running over ty with an empty substitution gives it the
- -- no-shadowing property. This is important. For example:
- -- type Foo r = forall a. a -> r
- -- foo :: Foo (Foo ())
- -- Here the hoisting should give
- -- foo :: forall a a1. a -> a1 -> ()
- --
- -- What about type vars that are lexically in scope in the envt?
- -- We simply rely on them having a different unique to any
- -- binder in 'ty'. Otherwise we'd have to slurp the in-scope-tyvars
- -- out of the envt, which is boring and (I think) not necessary.
- in
- case hoist no_shadow_ty of
- (tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body)
- -- The 'nubBy' eliminates duplicate constraints,
- -- notably implicit parameters
- where
- hoist ty
- | (tvs1, body_ty) <- tcSplitForAllTys ty,
- not (null tvs1)
- = case hoist body_ty of
- (tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau)
-
- | Just (arg, res) <- tcSplitFunTy_maybe ty
- = let
- arg' = hoistForAllTys arg -- Don't forget to apply hoist recursively
- in -- to the argument type
- if (isPredTy arg') then
- case hoist res of
- (tvs,theta,tau) -> (tvs, arg':theta, tau)
- else
- case hoist res of
- (tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau)
-
- | otherwise = ([], [], ty)