\begin{code}
module HsTypes (
- HsType(..), HsTyVarBndr(..),
+ HsType(..), HsTyVarBndr(..), HsTyOp(..),
, HsContext, HsPred(..)
, HsTupCon(..), hsTupParens, mkHsTupCon,
, hsUsOnce, hsUsMany
-- Type place holder
, PostTcType, placeHolderType,
+ -- Name place holder
+ , SyntaxName, placeHolderName,
+
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn )
import RdrName ( RdrName, mkUnqual )
-import Name ( Name, getName )
-import OccName ( NameSpace, tvName )
+import Name ( Name, getName, mkInternalName )
+import OccName ( NameSpace, mkVarOcc, tvName )
import Var ( TyVar, tyVarKind )
import Subst ( substTyWith )
-import PprType ( {- instance Outputable Kind -}, pprParendKind )
+import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
-import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
- usOnceTyConName, usManyTyConName
- )
-import FiniteMap
+import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey,
+ usOnceTyConKey, usManyTyConKey, hasKey, unboundKey,
+ usOnceTyConName, usManyTyConName )
+import SrcLoc ( builtinSrcLoc )
import Util ( eqListBy, lengthIs )
+import FiniteMap
import Outputable
\end{code}
placeHolderType :: PostTcType -- Used before typechecking
placeHolderType = panic "Evaluated the place holder for a PostTcType"
+
+
+type SyntaxName = Name -- These names are filled in by the renamer
+ -- Before then they are a placeHolderName (so that
+ -- we can still print the HsSyn)
+ -- They correspond to "rebindable syntax";
+ -- See RnEnv.lookupSyntaxName
+
+placeHolderName :: SyntaxName
+placeHolderName = mkInternalName unboundKey
+ (mkVarOcc FSLIT("syntaxPlaceHolder"))
+ builtinSrcLoc
\end{code}
| HsAppTy (HsType name)
(HsType name)
- | HsFunTy (HsType name) -- function type
+ | HsFunTy (HsType name) -- function type
(HsType name)
| 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
+
+ | HsOpTy (HsType name) (HsTyOp name) (HsType name)
+
+ | HsParTy (HsType name) -- Parenthesis preserved for the
+ -- precedence parser; are removed by
+ -- the type checker
+
+ | HsNumTy Integer -- Generics only
-- 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
+data HsTyOp name = HsArrow | HsTyOp name
+ -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2
+ -- But when we generate or parse interface files, we use HsFunTy.
+ -- This keeps interfaces a bit smaller, because there are a lot of arrows
+
-----------------------
hsUsOnce, hsUsMany :: HsType RdrName
-hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic
-hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic
+hsUsOnce = HsTyVar (mkUnqual tvName FSLIT(".")) -- deep magic
+hsUsMany = HsTyVar (mkUnqual tvName FSLIT("!")) -- deep magic
hsUsOnce_Name, hsUsMany_Name :: HsType Name
hsUsOnce_Name = HsTyVar usOnceTyConName
instance (Outputable name) => Outputable (HsType name) where
ppr ty = pprHsType ty
+instance (Outputable name) => Outputable (HsTyOp name) where
+ ppr HsArrow = ftext FSLIT("->")
+ ppr (HsTyOp n) = ppr n
+
instance (Outputable name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name) = ppr name
ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
(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 (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)
= 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
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) =
+ maybeParen (ctxt_prec >= pREC_FUN)
+ (ppr_mono_ty pREC_FUN ty1 <+> ppr op <+> ppr_mono_ty pREC_FUN ty2)
--- 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
+ppr_mono_ty ctxt_prec (HsParTy ty) = ppr_mono_ty ctxt_prec ty
+ -- `HsParTy' isn't useful for pretty printing, as it is removed by the type
+ -- checker and we need to be able to pretty print after type checking
+
+ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only
\end{code}
| 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
(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)
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_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
eq_hsType env ty1 ty2 = False
+eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2
+eq_hsOp env HsArrow HsArrow = True
+eq_hsOp env op1 op2 = False
+
-------------------
eq_hsContext env a b = eqListBy (eq_hsPred env) a b
projects / ghc-hetmet.git / blobdiff