, hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
- , hsTyVarName, hsTyVarNames, replaceTyVarName,
+ , hsTyVarName, hsTyVarNames, replaceTyVarName
+ , getHsInstHead
-- Type place holder
- PostTcType, placeHolderType,
+ , PostTcType, placeHolderType,
-- Printing
- , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
+ , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
import Name ( Name, getName )
import OccName ( NameSpace, tvName )
import Var ( TyVar, tyVarKind )
-import Subst ( mkTyVarSubst, substTy )
-import PprType ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes ( Boxity(..), Arity, tupleParens )
-import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
- usOnceTyConName, usManyTyConName
- )
+import Subst ( substTyWith )
+import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
+import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
+import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey,
+ usOnceTyConKey, usManyTyConKey, hasKey,
+ usOnceTyConName, usManyTyConName )
import FiniteMap
-import Util ( eqListBy )
+import Util ( eqListBy, lengthIs )
import Outputable
\end{code}
type HsContext name = [HsPred name]
data HsPred name = HsClassP name [HsType name]
- | HsIParam name (HsType name)
+ | HsIParam (IPName name) (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
| HsListTy (HsType name) -- Element type
+ | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:]
+
| HsTupleTy (HsTupCon name)
[HsType name] -- Element types (length gives arity)
-- Generics
-- these next two are only used in interfaces
| HsPredTy (HsPred name)
-
- | HsUsageTy (HsType name) -- Usage annotation
- (HsType name) -- Annotated type
+
+ | HsKindSig (HsType name) -- (ty :: kind)
+ Kind -- A type with a kind signature
-----------------------
\end{code}
+\begin{code}
+getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name]))
+ -- Split up an instance decl type, returning the 'head' part
+
+-- In interface fiels, the type of the decl is held like this:
+-- forall a. Foo a -> Baz (T a)
+-- so we have to strip off function argument types,
+-- as well as the bit before the '=>' (which is always
+-- empty in interface files)
+--
+-- The parser ensures the type will have the right shape.
+-- (e.g. see ParseUtil.checkInstType)
+
+getHsInstHead (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
+getHsInstHead tau = ([], get_head1 tau)
+
+get_head1 (HsFunTy _ ty) = get_head1 ty
+get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Pretty printing}
instance Outputable name => Outputable (HsPred name) where
ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
- ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
+ ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty]
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
ptext SLIT("forall") <+> interppSP tvs <> dot <+>
-- **! ToDo: want to hide uvars from user, but not enough info
-- in a HsTyVarBndr name (see PprType). KSW 2000-10.
- (if null cxt then
- empty
- else
- ppr_context cxt <+> ptext SLIT("=>")
- )
+ pprHsContext cxt
else -- Used in interfaces
ptext SLIT("__forall") <+> interppSP tvs <+>
- ppr_context cxt <+> ptext SLIT("=>")
+ ppr_hs_context cxt <+> ptext SLIT("=>")
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext [] = empty
-pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>")
+pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>")
-ppr_context [] = empty
-ppr_context cxt = parens (interpp'SP cxt)
+ppr_hs_context [] = empty
+ppr_hs_context cxt = parens (interpp'SP cxt)
\end{code}
\begin{code}
(sep [p1, (<>) (ptext SLIT("-> ")) p2])
ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys)
+ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind)
ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty)
+ where
+ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen (ctxt_prec >= pREC_CON)
ppr_mono_ty ctxt_prec (HsPredTy pred)
= braces (ppr pred)
-ppr_mono_ty ctxt_prec (HsUsageTy u ty)
- = maybeParen (ctxt_prec >= pREC_CON)
- (sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u,
- ppr_mono_ty pREC_CON ty])
- -- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy
-
-- Generics
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n
ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
where
syn_matches = ty_from_syn `tcEqType` real_ty
(tyvars,syn_ty) = getSynTyConDefn tycon
- ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) syn_ty
+ ty_from_syn = substTyWith tyvars tyargs syn_ty
-- We only use the type synonym in the file if this doesn't cause
-- us to lose important information. This matters for usage
| not saturated = generic_case
| isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
+ | tc `hasKey` parrTyConKey = HsPArrTy (head tys')
| tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified
| tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified
| otherwise = generic_case
where
generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
tys' = map toHsType tys
- saturated = length tys == tyConArity tc
+ saturated = tys `lengthIs` tyConArity tc
toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
(tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
(map toHsPred preds)
(toHsType tau)
-toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty)
- -- **! consider dropping usMany annotations ToDo KSW 2000-10
-
-
toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty)
+toHsPred (IParam n ty) = HsIParam n (toHsType ty)
toHsContext :: ThetaType -> HsContext Name
toHsContext theta = map toHsPred theta
eq_hsType env (HsListTy ty1) (HsListTy ty2)
= eq_hsType env ty1 ty2
+eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2)
+ = eq_hsType env ty1 ty2 && k1 `eqKind` k2
+
+eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2)
+ = eq_hsType env ty1 ty2
+
eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2)
= eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2
eq_hsType env (HsPredTy p1) (HsPredTy p2)
= eq_hsPred env p1 p2
-eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2)
- = eq_hsType env u1 u2 && eq_hsType env ty1 ty2
-
eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
= eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
projects / ghc-hetmet.git / blobdiff