HsType(..), HsTyVarBndr(..), HsTyOp(..),
, HsContext, HsPred(..)
, HsTupCon(..), hsTupParens, mkHsTupCon,
- , hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
- , getHsInstHead
+ , splitHsInstDeclTy
-- Type place holder
, PostTcType, placeHolderType,
import Subst ( substTyWith )
import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
-import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey,
- usOnceTyConKey, usManyTyConKey, hasKey, unboundKey,
- usOnceTyConName, usManyTyConName )
-import SrcLoc ( builtinSrcLoc )
+import PrelNames ( listTyConKey, parrTyConKey,
+ hasKey, unboundKey )
+import SrcLoc ( noSrcLoc )
import Util ( eqListBy, lengthIs )
import FiniteMap
import Outputable
placeHolderName :: SyntaxName
placeHolderName = mkInternalName unboundKey
(mkVarOcc FSLIT("syntaxPlaceHolder"))
- builtinSrcLoc
+ noSrcLoc
\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)
+ | HsTupleTy HsTupCon
[HsType name] -- Element types (length gives arity)
| HsOpTy (HsType name) (HsTyOp name) (HsType name)
+
+ | HsParTy (HsType name)
+ -- Parenthesis preserved for the precedence re-arrangement in RnTypes
+ -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
+ --
+ -- However, NB that toHsType doesn't add HsParTys (in an effort to keep
+ -- interface files smaller), so when printing a HsType we may need to
+ -- add parens.
+
| HsNumTy Integer -- Generics only
-- these next two are only used in interfaces
-- This keeps interfaces a bit smaller, because there are a lot of arrows
-----------------------
-hsUsOnce, hsUsMany :: HsType RdrName
-hsUsOnce = HsTyVar (mkUnqual tvName FSLIT(".")) -- deep magic
-hsUsMany = HsTyVar (mkUnqual tvName FSLIT("!")) -- deep magic
-
-hsUsOnce_Name, hsUsMany_Name :: HsType Name
-hsUsOnce_Name = HsTyVar usOnceTyConName
-hsUsMany_Name = HsTyVar usManyTyConName
-
------------------------
-data HsTupCon name = HsTupCon name Boxity Arity
+data HsTupCon = HsTupCon Boxity Arity
-instance Eq name => Eq (HsTupCon name) where
- (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2
+instance Eq HsTupCon where
+ (HsTupCon b1 a1) == (HsTupCon b2 a2) = b1==b2 && a1==a2
-mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
-mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity
- where
- arity = length args
+mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon
+mkHsTupCon space boxity args = HsTupCon boxity (length args)
-hsTupParens :: HsTupCon name -> SDoc -> SDoc
-hsTupParens (HsTupCon _ b _) p = tupleParens b p
+hsTupParens :: HsTupCon -> SDoc -> SDoc
+hsTupParens (HsTupCon b _) p = tupleParens b p
-----------------------
-- Combine adjacent for-alls.
--
-- A valid type must have one for-all at the top of the type, or of the fn arg types
-mkHsForAllTy (Just []) [] ty = ty -- Explicit for-all with no tyvars
-mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
- where
- mtvs1 `plus` Nothing = mtvs1
- Nothing `plus` mtvs2 = mtvs2
- (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
-mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
+mkHsForAllTy mtvs [] ty = mk_forall_ty mtvs ty
+mkHsForAllTy mtvs ctxt ty = HsForAllTy mtvs ctxt ty
+
+-- mk_forall_ty makes a pure for-all type (no context)
+mk_forall_ty (Just []) ty = ty -- Explicit for-all with no tyvars
+mk_forall_ty mtvs1 (HsParTy ty) = mk_forall_ty mtvs1 ty
+mk_forall_ty mtvs1 (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
+mk_forall_ty mtvs1 ty = HsForAllTy mtvs1 [] ty
+
+mtvs1 `plus` Nothing = mtvs1
+Nothing `plus` mtvs2 = mtvs2
+(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
mkHsIParamTy v ty = HsPredTy (HsIParam v ty)
\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.
+splitHsInstDeclTy
+ :: Outputable name
+ => HsType name
+ -> ([HsTyVarBndr name], HsContext name, name, [HsType name])
+ -- Split up an instance decl type, returning the pieces
+
+-- In interface files, the instance declaration head is created
+-- by HsTypes.toHsType, which does not guarantee to produce a
+-- HsForAllTy. For example, if we had the weird decl
+-- instance Foo T => Foo [T]
+-- then we'd get the instance type
+-- Foo T -> Foo [T]
+-- So when colleting the instance context, to be on the safe side
+-- we gather predicate arguments
+--
+-- For source code, 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)
+splitHsInstDeclTy inst_ty
+ = case inst_ty of
+ HsForAllTy (Just tvs) cxt1 tau
+ -> (tvs, cxt1++cxt2, cls, tys)
+ where
+ (cxt2, cls, tys) = split_tau tau
+
+ other -> ([], cxt2, cls, tys)
+ where
+ (cxt2, cls, tys) = split_tau inst_ty
-get_head1 (HsFunTy _ ty) = get_head1 ty
-get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
+ where
+ split_tau (HsFunTy (HsPredTy p) ty) = (p:ps, cls, tys)
+ where
+ (ps, cls, tys) = split_tau ty
+ split_tau (HsPredTy (HsClassP cls tys)) = ([], cls,tys)
+ split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
\end{code}
\begin{code}
pREC_TOP = (0 :: Int) -- type in ParseIface.y
pREC_FUN = (1 :: Int) -- btype in ParseIface.y
-pREC_CON = (2 :: Int) -- atype in ParseIface.y
-
-maybeParen :: Bool -> SDoc -> SDoc
-maybeParen True p = parens p
-maybeParen False p = p
+ -- Used for LH arg of (->)
+pREC_OP = (2 :: Int) -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = (3 :: Int) -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
+
+maybeParen :: Int -- Precedence of context
+ -> Int -- Precedence of top-level operator
+ -> SDoc -> SDoc -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
-- printing works more-or-less as for Types
pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
-pprHsType ty = ppr_mono_ty pREC_TOP ty
+pprHsType ty = ppr_mono_ty pREC_TOP (de_paren ty)
pprParendHsType ty = ppr_mono_ty pREC_CON ty
+-- Remove outermost HsParTy parens before printing a type
+de_paren (HsParTy ty) = de_paren ty
+de_paren ty = ty
+
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
- = maybeParen (ctxt_prec >= pREC_FUN) $
+ = maybeParen ctxt_prec pREC_FUN $
sep [pp_header, pprHsType ty]
where
pp_header = case maybe_tvs of
Just tvs -> pprHsForAll tvs ctxt
Nothing -> pprHsContext ctxt
-ppr_mono_ty ctxt_prec (HsTyVar name)
- = ppr name
-
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)
- = let p1 = ppr_mono_ty pREC_FUN ty1
- p2 = ppr_mono_ty pREC_TOP ty2
- in
- maybeParen (ctxt_prec >= pREC_FUN)
- (sep [p1, (<>) (ptext SLIT("-> ")) p2])
-
+ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
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 (HsPredTy pred) = braces (ppr pred)
+ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only
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])
+ = 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 (HsOpTy ty1 HsArrow ty2)
+ = ppr_fun_ty ctxt_prec ty1 ty2
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_ty pREC_OP ty1 <+> ppr op <+> ppr_mono_ty pREC_OP ty2
+
+ppr_mono_ty ctxt_prec (HsParTy ty)
+ = parens (ppr_mono_ty pREC_TOP ty)
+ -- Put the parens in where the user did
+ -- But we still use the precedence stuff to add parens because
+ -- toHsType doesn't put in any HsParTys, so we may still need them
+
+--------------------------
+ppr_fun_ty ctxt_prec ty1 ty2
+ = let p1 = ppr_mono_ty pREC_FUN ty1
+ p2 = ppr_mono_ty pREC_TOP ty2
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ sep [p1, ptext SLIT("->") <+> p2]
--- 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
+--------------------------
+pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
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'
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (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'