__interface DataCon 1 0 where
-__export DataCon DataCon isExistentialDataCon ;
+__export DataCon DataCon isExistentialDataCon dataConName ;
1 data DataCon ;
1 isExistentialDataCon :: DataCon -> PrelBase.Bool ;
+1 dataConName :: DataCon -> Name.Name ;
module DataCon where
data DataCon
+dataConName :: DataCon -> Name.Name
isExistentialDataCon :: DataCon -> GHC.Base.Bool
#include "HsVersions.h"
import {-# SOURCE #-} Subst( substTyWith )
-import {-# SOURCE #-} PprType( pprType )
import Type ( Type, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, splitTyConApp_maybe,
- mkPredTys, isStrictPred
+ mkPredTys, isStrictPred, pprType
)
import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon )
pprExternal sty name uniq mod occ mb_p is_wired
| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
| debugStyle sty = sep [ppr (moduleName mod) <> dot <> pprOccName occ,
- hsep [text "{-",
- if is_wired then ptext SLIT("(w)") else empty,
- pprUnique uniq,
- case mb_p of
- Nothing -> empty
- Just n -> brackets (ppr n),
- text "-}"]]
+ hsep [text "{-"
+ , if is_wired then ptext SLIT("(w)") else empty
+ , pprUnique uniq
+-- (overkill) , case mb_p of
+-- Nothing -> empty
+-- Just n -> brackets (ppr n)
+ , text "-}"]]
| unqualStyle sty name = pprOccName occ
| otherwise = ppr (moduleName mod) <> dot <> pprOccName occ
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.60 2003/05/14 09:13:53 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.61 2003/10/30 16:01:52 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
import Module ( Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..), getPrimRepSize )
-import PprType ( showTypeCategory )
import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
import Name ( nameOccName )
import OccName ( occNameFS )
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
+import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
+import Maybe
\end{code}
%********************************************************
in
(use_cc, blame_cc)
\end{code}
+
+
+\begin{code}
+showTypeCategory :: Type -> Char
+ {-
+ {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case tcSplitTyConApp_maybe ty of
+ Nothing -> if isJust (tcSplitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if isJust (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
+\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.59 2003/10/09 11:58:46 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.60 2003/10/30 16:01:52 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
-import Name ( Name, nameUnique, getOccName, getName )
+import Name ( Name, nameUnique, getOccName, getName, getOccString )
import OccName ( occNameUserString )
-import PprType ( getTyDescription )
import PrimRep
import SMRep -- all of it
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TcType ( tcSplitSigmaTy )
import TyCon ( isFunTyCon )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
import Util ( mapAccumL, listLengthCmp, lengthIs )
import FastString
import Outputable
= getTyDescription ty
closureTypeDescr (ConInfo { closureCon = data_con })
= occNameUserString (getOccName (dataConTyCon data_con))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res -> '-' : '>' : fun_result res
+ NewTcApp tycon _ -> getOccString tycon
+ TyConApp tycon _ -> getOccString tycon
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
+ PredTy sty -> getPredTyDescription sty
+ ForAllTy _ ty -> getTyDescription ty
+ }
+ where
+ fun_result (FunTy _ res) = '>' : fun_result res
+ fun_result other = getTyDescription other
+
+getPredTyDescription (ClassP cl tys) = getOccString cl
+getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
%************************************************************************
globalIdDetails, isGlobalId, isExportedId,
isSpecPragmaId, idNewDemandInfo
)
-import Var ( isTyVar )
+import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
-import PprType ( pprParendType, pprType, pprTyVarBndr )
+import Type ( pprParendType, pprType, pprParendKind )
import BasicTypes ( tupleParens )
import Util ( lengthIs )
import Outputable
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
-- [Jun 2002: interfaces are now binary, so this doesn't matter]
+pprTyVarBndr :: TyVar -> SDoc
+pprTyVarBndr tyvar
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ hsep [ppr tyvar, dcolon, pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
+ else
+ ppr tyvar
+ where
+ kind = tyVarKind tyvar
+
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr id = ppr id <+>
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
- = ASSERT2(isUnLiftedType data_con_arg_ty1, crudePprType arg_ty)
+ = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
-- Typechecker ensures this
newSysLocalDs arg_ty `thenDs` \ case_bndr ->
newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
-import Type ( Type, repType, splitFunTys, dropForAlls )
+import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
import Util
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
-import PprType ( pprType )
import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
import Bitmap ( intsToReverseBitmap, mkBitmap )
import OrdList
import HsImpExp ( isOperator, pprHsVar )
-- others:
-import PprType ( pprParendType )
-import Type ( Type )
+import Type ( Type, pprParendType )
import Var ( TyVar, Id )
import Name ( Name )
import DataCon ( DataCon )
#include "HsVersions.h"
import TcType ( Type, Kind, liftedTypeKind, eqKind )
-import TypeRep ( Type )
+import Type ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import Name ( Name, mkInternalName )
import OccName ( mkVarOcc )
-import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( IPName, Boxity, tupleParens )
import PrelNames ( unboundKey )
import SrcLoc ( noSrcLoc )
#include "HsVersions.h"
import Type ( openTypeKind, liftedTypeKind, unliftedTypeKind,
- splitFunTy_maybe, eqKind )
+ splitFunTy_maybe, eqKind, pprType )
import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
import Var ( isId, tyVarKind, idType )
import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
import Outputable
import FastString
-
-#ifdef DEBUG
-import TypeRep( crudePprType )
-#endif
\end{code}
| Just (arg,res) <- splitFunTy_maybe k
= IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
#ifdef DEBUG
- | otherwise = pprTrace "toIfaceKind" (crudePprType k) IfaceOpenTypeKind
+ | otherwise = pprTrace "toIfaceKind" (pprType k) IfaceOpenTypeKind
#endif
---------------------
import TcRnMonad
import Type ( Kind, openTypeKind, liftedTypeKind,
unliftedTypeKind, mkArrowKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+ mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
import InstEnv ( extendInstEnv )
import CoreSyn
-import PprType ( pprClassPred )
import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
)
import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind,
- isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep,
+ isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType,
splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
)
import TypeRep ( Type(..) )
import Char ( ord )
import List ( partition, elem, insertBy,any )
import UniqSet
-import PprType ( pprType ) -- Only called in debug messages
import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
isClassPred, isTyVarClassPred, isLinearPred,
getClassPredTys, getClassPredTys_maybe, mkPredName,
isInheritablePred, isIPPred, matchTys,
- tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
+ tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
+ pprPred, pprParendType, pprThetaArrow, pprClassPred
)
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
import NameSet ( addOneToNameSet )
-import PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred )
import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar )
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
- HsExplicitForAll(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isPragSig, placeHolderType, mkExplicitHsForAllTy
)
import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2,
- InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
+ InstInfo(..), pprInstInfoDetails,
+ simpleInstInfoTyCon, simpleInstInfoTy,
InstBindings(..), newDFunName
)
import TcBinds ( tcMonoBinds, tcSpecSigs )
wild_pats = [WildPat placeHolderType | ty <- arg_tys]
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
- = -- A generic default method
- -- If the method is defined generically, we can only do the job if the
+ = -- A generic default method
+ -- If the method is defined generically, we can only do the job if the
-- instance declaration is for a single-parameter type class with
-- a type constructor applied to type arguments in the instance decl
-- (checkTc, so False provokes the error)
- ASSERT( isInstDecl origin ) -- We never get here from a class decl
-
- checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys)) `thenM_`
- checkTc (tyConHasGenerics tycon)
- (badGenericInstance sel_id (notGeneric tycon)) `thenM_`
-
- ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_`
-
- -- Rename it before returning it
- rnExpr rhs `thenM` \ (rn_rhs, _) ->
- returnM rn_rhs
+ ASSERT( isInstDecl origin ) -- We never get here from a class decl
+ do { checkTc (isJust maybe_tycon)
+ (badGenericInstance sel_id (notSimple inst_tys))
+ ; checkTc (tyConHasGenerics tycon)
+ (badGenericInstance sel_id (notGeneric tycon))
+
+ ; dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+ (vcat [ppr clas <+> ppr inst_tys,
+ nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+ -- Rename it before returning it
+ ; (rn_rhs, _) <- rnExpr rhs
+ ; returnM rn_rhs }
where
rhs = mkGenericRhs sel_id clas_tyvar tycon
- stuff = vcat [ppr clas <+> ppr inst_tys,
- nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
-
-- The tycon is only used in the generic case, and in that
-- case we require that the instance decl is for a single-parameter
-- type class with type variable arguments:
-- Otherwise print it out
{ dflags <- getDOpts
; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfo gen_inst_info)))
+ (vcat (map pprInstInfoDetails gen_inst_info)))
; returnM gen_inst_info }}
get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc})
checkTc (null missing) (missingGenericInstances missing) `thenM_`
returnM inst_infos
-
where
generic_binds :: [(HsType Name, RenamedMonoBinds)]
generic_binds = getGenericBinds def_methods
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
- = vcat (map ppr_info inst_infos) $$ ppr extra_binds
-
- ppr_info inst_info = pprInstInfo inst_info $$
- nest 4 (pprInstInfoDetails inst_info)
- -- pprInstInfo doesn't print much: only the type
+ = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
-----------------------------------------
deriveOrdinaryStuff [] -- Short cut
pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
-pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
-pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
+pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
+ where
+ details (VanillaInst b _) = ppr b
+ details (NewTypeDerived _) = text "Derived from the representation type"
simpleInstInfoTy :: InstInfo -> Type
simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, eqKind,
- tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy
- )
-import PprType ( pprKind, pprThetaArrow )
+ tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy,
+ pprKind, pprThetaArrow )
import qualified Type ( splitFunTys )
import Inst ( Inst, InstOrigin(..), newMethod, instToId )
checkAmbiguity, SourceTyCtxt(..) )
import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
- TyVarDetails(..), tcSplitDFunTy
- )
+ TyVarDetails(..), tcSplitDFunTy, pprClassPred )
import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId,
showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )
InstInfo(..), InstBindings(..),
newDFunName, tcExtendLocalValEnv
)
-import PprType ( pprClassPred )
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
liftedTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, typeKind,
tyVarsOfType, tyVarsOfTypes,
- eqKind, isTypeKind,
- )
-import PprType ( pprThetaArrow )
+ eqKind, isTypeKind, pprThetaArrow,
+ pprPred, pprTheta, pprClassPred )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
-- others:
import TcRnMonad -- TcType, amongst others
import FunDeps ( grow )
-import PprType ( pprPred, pprTheta, pprClassPred )
import Name ( Name, setNameUnique, mkSystemTvNameEncoded )
import VarSet
import CmdLineOpts ( dopt, DynFlag(..) )
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- addSrcLoc splice_loc $
rnExpr splice_expr ;
+ failIfErrsM ; -- Don't typecheck if renaming failed
+
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
import TcType ( TcKind, ThetaType, TcType,
mkArrowKind, liftedTypeKind,
tcSplitSigmaTy, tcEqType )
-import Type ( splitTyConApp_maybe )
-import PprType ( pprThetaArrow, pprParendType )
+import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig )
import Type ( predTypeRep )
import BuildTyCl ( newTyConRhs )
import HscTypes ( TyThing(..) )
-import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,
+import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
import Class ( classTyCon )
import NameEnv
import NameSet
import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
-import Maybe ( isNothing )
import BasicTypes ( RecFlag(..) )
import Outputable
\end{code}
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
typeKind, eqKind,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
- ) where
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-#include "HsVersions.h"
+ pprKind, pprParendKind,
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
+ ) where
-import {-# SOURCE #-} PprType( pprType )
--- PprType imports TcType so that it can print intelligently
+#include "HsVersions.h"
-- friends:
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
tidyTyVarBndr, tidyOpenTyVar,
tidyOpenTyVars, eqKind,
hasMoreBoxityInfo, liftedBoxity,
- superBoxity, typeKind, superKind, repType
+ superBoxity, typeKind, superKind, repType,
+ pprKind, pprParendKind,
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
import Class ( Class )
isSkolemTyVar, isUserTyVar,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind,
- hasMoreBoxityInfo, allDistinctTyVars
- )
+ hasMoreBoxityInfo, allDistinctTyVars, pprType )
import Inst ( newDicts, instToId, tcInstCall )
import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
newTyVarTy, newTyVarTys, newOpenTypeKind,
import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon )
import TcEnv ( tcGetGlobalTyVars, findGlobals )
import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity )
-import PprType ( pprType )
import Id ( Id, mkSysLocal )
import Var ( Var, varName, tyVarKind )
import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred,
unifyTyListsX, unifyExtendTysX, tcEqType
)
-import PprType ( )
import VarSet
import VarEnv
import Outputable
+++ /dev/null
-_interface_ PprType 1
-_exports_
-PprType pprType pprPred;
-_declarations_
-1 pprType _:_ TypeRep.Type -> Outputable.SDoc ;;
-1 pprPred _:_ Type.PredType -> Outputable.SDoc ;;
-
+++ /dev/null
-__interface PprType 1 0 where
-__export PprType pprType pprPred ;
-1 pprType :: TypeRep.Type -> Outputable.SDoc ;
-1 pprPred :: Type.PredType -> Outputable.SDoc ;
-
+++ /dev/null
-module PprType where
-
-pprType :: TypeRep.Type -> Outputable.SDoc
-pprPred :: Type.PredType -> Outputable.SDoc
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[PprType]{Printing Types, TyVars, Classes, TyCons}
-
-\begin{code}
-module PprType(
- pprKind, pprParendKind,
- pprType, pprParendType,
- pprPred, pprTheta, pprThetaArrow, pprClassPred,
- pprTyVarBndr, pprTyVarBndrs,
-
- -- Junk
- getTyDescription, showTypeCategory
- ) where
-
-#include "HsVersions.h"
-
--- friends:
--- (PprType can see all the representations it's trying to print)
-import TypeRep ( Type(..), TyNote(..), PredType(..), TyThing(..), Kind, superKind ) -- friend
-import Type ( typeKind, eqKind )
-import IfaceType ( toIfaceType, toIfacePred, pprParendIfaceType,
- toIfaceKind, pprParendIfaceKind,
- getIfaceExt )
-
-import TcType ( ThetaType, PredType,
- tcSplitSigmaTy, isDictTy,
- tcSplitTyConApp_maybe, tcSplitFunTy_maybe
- )
-import Var ( TyVar, tyVarKind )
-import Class ( Class )
-import TyCon ( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon )
-
--- others:
-import Maybes ( maybeToBool )
-import Name ( NamedThing(..), getOccString )
-import Outputable
-import BasicTypes ( IPName(..), ipNameName )
-import PrelNames -- quite a few *Keys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The external interface}
-%* *
-%************************************************************************
-
-@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
-defined to use this. @pprParendType@ is the same, except it puts
-parens around the type, except for the atomic cases. @pprParendType@
-works just by setting the initial context precedence very high.
-
-\begin{code}
-pprType, pprParendType :: Type -> SDoc
--- To save duplicating type-printing machinery,
--- we print a type by converting to an IfaceType and printing that
-pprType ty = getIfaceExt $ \ ext ->
- ppr (toIfaceType ext ty)
-pprParendType ty = getIfaceExt $ \ ext ->
- pprParendIfaceType (toIfaceType ext ty)
-
-pprKind, pprParendKind :: Kind -> SDoc
-pprKind k = ppr (toIfaceKind k)
-pprParendKind k = pprParendIfaceKind (toIfaceKind k)
-
-pprPred :: PredType -> SDoc
-pprPred pred = getIfaceExt $ \ ext ->
- ppr (toIfacePred ext pred)
-
-pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
-
-pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
-
-pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow theta
- | null theta = empty
- | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
-
-instance Outputable Type where
- ppr ty | typeKind ty `eqKind` superKind = pprKind ty
- | otherwise = pprType ty
-
-instance Outputable PredType where
- ppr = pprPred
-
-instance Outputable name => OutputableBndr (IPName name) where
- pprBndr _ n = ppr n -- Simple for now
-
-instance Outputable TyThing where
- ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
- ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
- ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
- ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc
-
-instance NamedThing TyThing where -- Can't put this with the type
- getName (AnId id) = getName id -- decl, because the DataCon instance
- getName (ATyCon tc) = getName tc -- isn't visible there
- getName (AClass cl) = getName cl
- getName (ADataCon dc) = getName dc
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection[TyVar]{@TyVar@}
-%* *
-%************************************************************************
-
-We print type-variable binders with their kinds in interface files,
-and when in debug mode.
-
-\begin{code}
-pprTyVarBndr :: TyVar -> SDoc
-pprTyVarBndr tyvar
- = getPprStyle $ \ sty ->
- if debugStyle sty then
- hsep [ppr tyvar, dcolon, pprParendKind kind]
- -- See comments with ppDcolon in PprCore.lhs
- else
- ppr tyvar
- where
- kind = tyVarKind tyvar
-
-pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Mumbo jumbo}
-%* *
-%************************************************************************
-
-Grab a name for the type. This is used to determine the type
-description for profiling.
-
-\begin{code}
-getTyDescription :: Type -> String
-
-getTyDescription ty
- = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
- case tau_ty of
- TyVarTy _ -> "*"
- AppTy fun _ -> getTyDescription fun
- FunTy _ res -> '-' : '>' : fun_result res
- NewTcApp tycon _ -> getOccString tycon
- TyConApp tycon _ -> getOccString tycon
- NoteTy (FTVNote _) ty -> getTyDescription ty
- NoteTy (SynNote ty1) _ -> getTyDescription ty1
- PredTy sty -> getPredTyDescription sty
- ForAllTy _ ty -> getTyDescription ty
- }
- where
- fun_result (FunTy _ res) = '>' : fun_result res
- fun_result other = getTyDescription other
-
-getPredTyDescription (ClassP cl tys) = getOccString cl
-getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
-\end{code}
-
-
-\begin{code}
-showTypeCategory :: Type -> Char
- {-
- {C,I,F,D} char, int, float, double
- T tuple
- S other single-constructor type
- {c,i,f,d} unboxed ditto
- t *unpacked* tuple
- s *unpacked" single-cons...
-
- v void#
- a primitive array
-
- E enumeration type
- + dictionary, unless it's a ...
- L List
- > function
- M other (multi-constructor) data-con type
- . other type
- - reserved for others to mark as "uninteresting"
- -}
-showTypeCategory ty
- = if isDictTy ty
- then '+'
- else
- case tcSplitTyConApp_maybe ty of
- Nothing -> if maybeToBool (tcSplitFunTy_maybe ty)
- then '>'
- else '.'
-
- Just (tycon, _) ->
- let utc = getUnique tycon in
- if utc == charDataConKey then 'C'
- else if utc == intDataConKey then 'I'
- else if utc == floatDataConKey then 'F'
- else if utc == doubleDataConKey then 'D'
- else if utc == smallIntegerDataConKey ||
- utc == largeIntegerDataConKey then 'J'
- else if utc == charPrimTyConKey then 'c'
- else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
- || utc == addrPrimTyConKey) then 'i'
- else if utc == floatPrimTyConKey then 'f'
- else if utc == doublePrimTyConKey then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
- else if isEnumerationTyCon tycon then 'E'
- else if isTupleTyCon tycon then 'T'
- else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
- else if utc == listTyConKey then 'L'
- else 'M' -- oh, well...
-\end{code}
eqType, eqKind,
-- Seq
- seqType, seqTypes
+ seqType, seqTypes,
+ -- Pretty-printing
+ pprKind, pprParendKind,
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
splitFunTy (NoteTy _ ty) = splitFunTy ty
splitFunTy (PredTy p) = splitFunTy (predTypeRep p)
splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
-splitFunTy other = pprPanic "splitFunTy" (crudePprType other)
+splitFunTy other = pprPanic "splitFunTy" (ppr other)
splitFunTy_maybe :: Type -> Maybe (Type, Type)
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
split acc xs nty (NoteTy _ ty) = split acc xs nty ty
split acc xs nty (PredTy p) = split acc xs nty (predTypeRep p)
split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys)
- split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty)
+ split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
funResultTy :: Type -> Type
funResultTy (FunTy arg res) = res
funResultTy (NoteTy _ ty) = funResultTy ty
funResultTy (PredTy p) = funResultTy (predTypeRep p)
funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
-funResultTy ty = pprPanic "funResultTy" (crudePprType ty)
+funResultTy ty = pprPanic "funResultTy" (ppr ty)
funArgTy :: Type -> Type
funArgTy (FunTy arg res) = arg
funArgTy (NoteTy _ ty) = funArgTy ty
funArgTy (PredTy p) = funArgTy (predTypeRep p)
funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
-funArgTy ty = pprPanic "funArgTy" (crudePprType ty)
+funArgTy ty = pprPanic "funArgTy" (ppr ty)
\end{code}
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp ty = case splitTyConApp_maybe ty of
Just stuff -> stuff
- Nothing -> pprPanic "splitTyConApp" (crudePprType ty)
+ Nothing -> pprPanic "splitTyConApp" (ppr ty)
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
FunTy _ _ -> PtrRep
AppTy _ _ -> PtrRep -- ??
TyVarTy _ -> PtrRep
- other -> pprPanic "typePrimRep" (crudePprType ty)
+ other -> pprPanic "typePrimRep" (ppr ty)
\end{code}
= substTyWith (take n_args tvs) arg_tys
(mkForAllTys (drop n_args tvs) rho_ty)
| otherwise -- Too many type args
- = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty ) -- Zero case gives infnite loop!
+ = ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop!
applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
(drop n_tvs arg_tys)
where
openKindCon, -- :: KX
typeCon, -- :: BX -> KX
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
- crudePprType -- Prints type representations for debugging
+ -- Pretty-printing
+ pprKind, pprParendKind,
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
-import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} DataCon( DataCon, dataConName )
-- friends:
import Var ( Id, TyVar, tyVarKind )
import VarEnv ( TyVarEnv )
import VarSet ( TyVarSet )
-import Name ( Name, mkWiredInName, mkInternalName )
+import Name ( Name, NamedThing(..), mkWiredInName, mkInternalName )
import OccName ( mkOccFS, mkKindOccFS, tcName )
-import BasicTypes ( IPName )
-import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon )
+import BasicTypes ( IPName, tupleParens )
+import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon,
+ tyConArity, tupleTyConBoxity, isTupleTyCon, tyConName )
import Class ( Class )
-- others
import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey,
unliftedConKey, typeConKey, anyBoxConKey,
- funTyConKey
+ funTyConKey, listTyConKey, parrTyConKey,
+ hasKey
)
import SrcLoc ( noSrcLoc )
import Outputable
openTypeKind = TyConApp openKindCon []
\end{code}
+\begin{code}
+isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind :: Kind -> Bool
+isLiftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName &&
+ tyConName bc == liftedConName
+isUnliftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName &&
+ tyConName bc == unliftedConName
+isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName
+
+isSuperKind (TyConApp tc []) = tyConName tc == superKindName
+\end{code}
+
------------------------------------------
Define arrow kinds
| ADataCon DataCon
| ATyCon TyCon
| AClass Class
+
+instance Outputable TyThing where
+ ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
+ ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
+ ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
+ ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
+
+instance NamedThing TyThing where -- Can't put this with the type
+ getName (AnId id) = getName id -- decl, because the DataCon instance
+ getName (ATyCon tc) = getName tc -- isn't visible there
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = dataConName dc
\end{code}
\end{code}
-
%************************************************************************
%* *
- Crude printing
- For debug purposes, we may want to print a type directly
+\subsection{The external interface}
%* *
%************************************************************************
+@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
+defined to use this. @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases. @pprParendType@
+works just by setting the initial context precedence very high.
+
\begin{code}
-crudePprType :: Type -> SDoc
-crudePprType (TyVarTy tv) = ppr tv
-crudePprType (AppTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2))
-crudePprType (FunTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2))
-crudePprType (TyConApp tc tys) = ppr_tc_app (ppr tc <> pp_nt tc) tys
-crudePprType (NewTcApp tc tys) = ptext SLIT("<nt>") <+> ppr_tc_app (ppr tc <> pp_nt tc) tys
-crudePprType (ForAllTy tv ty) = sep [ptext SLIT("forall") <+>
- parens (ppr tv <+> crudePprType (tyVarKind tv)) <> dot,
- crudePprType ty]
-crudePprType (PredTy st) = braces (crudePprPredTy st)
-crudePprType (NoteTy (SynNote ty1) ty2) = crudePprType ty1
-crudePprType (NoteTy other ty) = crudePprType ty
-
-crudePprPredTy (ClassP cls tys) = ppr_tc_app (ppr cls) tys
-crudePprPredTy (IParam ip ty) = ppr ip <> dcolon <> crudePprType ty
-
-ppr_tc_app :: SDoc -> [Type] -> SDoc
-ppr_tc_app tc tys = tc <+> sep (map (parens . crudePprType) tys)
-
-pp_nt tc | isNewTyCon tc = ptext SLIT("(nt)")
- | otherwise = empty
-\end{code}
\ No newline at end of file
+data Prec = TopPrec -- No parens
+ | FunPrec -- Function args; no parens for tycon apps
+ | TyConPrec -- Tycon args; no parens for atomic
+ deriving( Eq, Ord )
+
+maybeParen :: Prec -> Prec -> SDoc -> SDoc
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = parens pretty
+
+------------------
+pprType, pprParendType :: Type -> SDoc
+pprType ty = ppr_type TopPrec ty
+pprParendType ty = ppr_type TyConPrec ty
+
+------------------
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind k = ppr_kind TopPrec k
+pprParendKind k = ppr_kind TyConPrec k
+
+------------------
+pprPred :: PredType -> SDoc
+pprPred (ClassP cls tys) = pprClassPred cls tys
+pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
+
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
+
+pprTheta :: ThetaType -> SDoc
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+
+pprThetaArrow :: ThetaType -> SDoc
+pprThetaArrow theta
+ | null theta = empty
+ | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
+
+------------------
+instance Outputable Type where
+ ppr ty = pprType ty
+
+instance Outputable PredType where
+ ppr = pprPred
+
+instance Outputable name => OutputableBndr (IPName name) where
+ pprBndr _ n = ppr n -- Simple for now
+
+------------------
+ -- OK, here's the main printer
+
+ppr_type :: Prec -> Type -> SDoc
+ppr_type p (TyVarTy tv) = ppr tv
+ppr_type p (PredTy pred) = braces (ppr pred)
+ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
+ppr_type p (NoteTy other ty2) = ppr_type p ty2
+
+ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ppr_type p (NewTcApp tc tys) = ifPprDebug (ptext SLIT("<nt>")) <>
+ ppr_tc_app p tc tys
+
+ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
+ pprType t1 <+> ppr_type TyConPrec t2
+
+ppr_type p (FunTy ty1 ty2)
+ = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ maybeParen p FunPrec $
+ sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ where
+ ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+
+ppr_type p ty@(ForAllTy _ _)
+ = maybeParen p FunPrec $
+ sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ where
+ (tvs, rho) = split1 [] ty
+ (ctxt, tau) = split2 [] rho
+
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
+
+ split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
+ split2 ps ty = (reverse ps, ty)
+
+ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
+ppr_tc_app p tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pprType ty)
+ | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
+ppr_tc_app p tc tys
+ | isTupleTyCon tc && tyConArity tc == length tys
+ = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
+ | otherwise
+ = maybeParen p TyConPrec $
+ ppr tc <+> sep (map (ppr_type TyConPrec) tys)
+
+-------------------
+pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
+
+pprTvBndr tv | isLiftedTypeKind kind = ppr tv
+ | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind)
+ where
+ kind = tyVarKind tv
+
+
+-------------------
+ppr_kind :: Prec -> Kind -> SDoc
+ppr_kind p k
+ | isOpenTypeKind k = ptext SLIT("?")
+ | isLiftedTypeKind k = ptext SLIT("*")
+ | isUnliftedTypeKind k = ptext SLIT("#")
+ppr_kind p (TyVarTy tv) = ppr tv
+ppr_kind p (FunTy k1 k2) = maybeParen p FunPrec $
+ sep [ ppr_kind FunPrec k1, arrow <+> pprKind k2]
+ppr_kind p other = ptext SLIT("STRANGE KIND:") <+> ppr_type p other
+\end{code}
+
projects / ghc-hetmet.git / commitdiff