, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
+ , getHsInstHead
+
+ -- Type place holder
+ , PostTcType, placeHolderType,
-- Printing
- , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
+ , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
#include "HsVersions.h"
import Class ( FunDep )
-import Type ( Type, Kind, PredType(..), ClassContext,
- splitSigmaTy, liftedTypeKind
+import TcType ( Type, Kind, ThetaType, SourceType(..),
+ tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
-import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn )
+import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn )
import RdrName ( RdrName, mkUnqual )
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, lengthIs )
import Outputable
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Annotating the syntax}
+%* *
+%************************************************************************
+
+\begin{code}
+type PostTcType = Type -- Used for slots in the abstract syntax
+ -- where we want to keep slot for a type
+ -- to be added by the type checker...but
+ -- before typechecking it's just bogus
+placeHolderType :: PostTcType -- Used before typechecking
+placeHolderType = panic "Evaluated the place holder for a PostTcType"
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Data types}
+%* *
+%************************************************************************
+
This is the syntax for types as seen in type signatures.
\begin{code}
type HsContext name = [HsPred name]
-data HsPred name = HsPClass name [HsType name]
- | HsPIParam name (HsType name)
+data HsPred name = HsClassP 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
| HsOpTy (HsType name) name (HsType name)
| HsNumTy Integer
+
-- 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
-----------------------
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
-mkHsDictTy cls tys = HsPredTy (HsPClass cls tys)
-mkHsIParamTy v ty = HsPredTy (HsPIParam v ty)
+mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
+mkHsIParamTy v ty = HsPredTy (HsIParam v ty)
data HsTyVarBndr name
= UserTyVar name
\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}
ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
instance Outputable name => Outputable (HsPred name) where
- ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
- ppr (HsPIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
+ ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
+ ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty]
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
-pprHsTyVarBndr name kind | kind == liftedTypeKind = ppr name
- | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
+pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
+ | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
pprHsForAll tvs cxt
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)
(hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
ppr_mono_ty ctxt_prec (HsPredTy pred)
- = maybeParen (ctxt_prec >= pREC_FUN) $
- 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
+ = braces (ppr pred)
-- Generics
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n
toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
-toHsType (NoteTy (SynNote syn_ty) real_ty)
- | syn_matches = toHsType syn_ty -- Use synonyms if possible!!
- | otherwise =
+toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty)
+ | isNewTyCon tycon = toHsType ty
+ | syn_matches = toHsType ty -- Use synonyms if possible!!
+ | otherwise =
#ifdef DEBUG
- pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
+ pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
#endif
- toHsType real_ty -- but drop it if not.
+ toHsType real_ty -- but drop it if not.
where
- syn_matches = ty_from_syn == real_ty
-
- TyConApp syn_tycon tyargs = syn_ty
- (tyvars,ty) = getSynTyConDefn syn_tycon
- ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) ty
+ syn_matches = ty_from_syn `tcEqType` real_ty
+ (tyvars,syn_ty) = getSynTyConDefn tycon
+ 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
-- error messages, but it's too much work for right now.
-- KSW 2000-07.
-toHsType (NoteTy _ ty) = toHsType ty
+toHsType (NoteTy _ ty) = toHsType ty
-toHsType (PredTy p) = HsPredTy (toHsPred p)
+toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys)
+toHsType (SourceTy pred) = HsPredTy (toHsPred pred)
toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| 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 splitSigmaTy ty of
+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 n (toHsType ty)
-toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty)
-
-toHsContext :: ClassContext -> HsContext Name
-toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
+toHsContext :: ThetaType -> HsContext Name
+toHsContext theta = map toHsPred theta
toHsFDs :: [FunDep TyVar] -> [FunDep Name]
toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
eq_hsTyVars env _ _ _ = False
eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2)
-eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 == k2 && k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2)
eq_hsTyVar env _ _ _ = False
eq_hsVars env [] [] k = k env
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
eq_hsContext env a b = eqListBy (eq_hsPred env) a b
-------------------
-eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2)
+eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2)
= c1 == c2 && eq_hsTypes env tys1 tys2
-eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2)
+eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2)
= n1 == n2 && eq_hsType env ty1 ty2
eq_hsPred env _ _ = False
-
--------------------
-eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
-eqListBy eq [] [] = True
-eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
-eqListBy eq xs ys = False
\end{code}