\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcHsType (
- tcHsSigType, tcHsDeriv,
+ tcHsSigType, tcHsDeriv,
+ tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
-- Kind checking
; checkValidType ctxt ty
; returnM ty }
+tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type)
+-- Typecheck an instance head. We can't use
+-- tcHsSigType, because it's not a valid user type.
+tcHsInstHead hs_ty
+ = do { kinded_ty <- kcHsSigType hs_ty
+ ; poly_ty <- tcHsKindedType kinded_ty
+ ; return (tcSplitSigmaTy poly_ty) }
+
+tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
+-- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
+-- except that we want to keep the tvs separate
+tcHsQuantifiedType tv_names hs_ty
+ = kcHsTyVars tv_names $ \ tv_names' ->
+ do { kc_ty <- kcHsSigType hs_ty
+ ; tcTyVarBndrs tv_names' $ \ tvs ->
+ do { ty <- dsHsType kc_ty
+ ; return (tvs, ty) } }
+
-- Used for the deriving(...) items
tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
tcHsDeriv = addLocM (tc_hs_deriv [])
split (L _ (HsAppTy f a)) as = split f (a:as)
split f as = (f,as)
mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of
- -- the application; they are never used
-
+ -- the application; they are
+ -- never used
+
+kc_hs_type ty@(HsPredTy (HsEqualP _ _))
+ = wrongEqualityErr
+
kc_hs_type (HsPredTy pred)
= kcHsPred pred `thenM` \ pred' ->
returnM (HsPredTy pred', liftedTypeKind)
}
kc_pred pred@(HsEqualP ty1 ty2)
= do { (ty1', kind1) <- kcHsType ty1
- ; checkExpectedKind ty1 kind1 liftedTypeKind
+-- ; checkExpectedKind ty1 kind1 liftedTypeKind
; (ty2', kind2) <- kcHsType ty2
- ; checkExpectedKind ty2 kind2 liftedTypeKind
- ; returnM (HsEqualP ty1 ty2, liftedTypeKind)
+-- ; checkExpectedKind ty2 kind2 liftedTypeKind
+ ; checkExpectedKind ty2 kind2 kind1
+ ; returnM (HsEqualP ty1' ty2', liftedTypeKind)
}
---------------------------
where
zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
; return (mkTyVar name kind') }
- zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
+ zonk (UserTyVar name) = WARN( True, ptext SLIT("Un-kinded tyvar") <+> ppr name )
return (mkTyVar name liftedTypeKind)
-----------------------------------
= do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
; span <- getSrcSpanM
; us <- newUniqueSupply
- ; let loc = srcSpanStart span
- uniqs = uniqsFromSupply us
- ; return [ mk_tv loc uniq str kind
+ ; let uniqs = uniqsFromSupply us
+ ; return [ mk_tv span uniq str kind
| ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] }
where
(arg_kinds, res_kind) = splitKindFunTys kind
| n <- nameSetToList (extractHsTyVars hs_ty),
not (in_scope n) ]
- -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
- -- except that we want to keep the tvs separate
- ; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do
- { kinded_ty <- kcTypeType hs_ty
- ; return (kinded_tvs, kinded_ty) }
- ; tcTyVarBndrs kinded_tvs $ \ tyvars -> do
- { sig_ty <- dsHsType kinded_ty
+ ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
; checkValidType ctxt sig_ty
; return (tyvars, sig_ty)
- } }
+ }
tcPatSig :: UserTypeCtxt
-> LHsType Name
= hang (ptext SLIT("The scoped type variables") <+> quotes (ppr n) <+> ptext SLIT("and") <+> quotes (ppr n'))
2 (vcat [ptext SLIT("are bound to the same type (variable)"),
ptext SLIT("Distinct scoped type variables must be distinct")])
+
+wrongEqualityErr
+ = failWithTc (text "Equality predicate used as a type")
\end{code}