, 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, ThetaType, PredType(..),
- 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 Subst ( substTyWith )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes ( Boxity(..), Arity, tupleParens )
+import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, 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 = 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
-- Generics
| HsOpTy (HsType name) name (HsType name)
| HsNumTy Integer
+
-- these next two are only used in interfaces
| HsPredTy (HsPred 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}
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 == 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}
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
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)
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_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_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}
projects / ghc-hetmet.git / blobdiff