From 86bb6b04f71652213c89fb9b13539baf3f1d57fb Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 7 Nov 2019 14:31:15 -0500 Subject: Ensure that coreView/tcView are able to inline Previously an import cycle between Type and TyCoRep meant that several functions in TyCoRep ended up SOURCE import coreView. This is quite unfortunate as coreView is intended to be fused into a larger pattern match and not incur an extra call. Fix this with a bit of restructuring: * Move the functions in `TyCoRep` which depend upon things in `Type` into `Type` * Fold contents of `Kind` into `Type` and turn `Kind` into a simple wrapper re-exporting kind-ish things from `Type` * Clean up the redundant imports that popped up as a result Closes #17441. Metric Decrease: T4334 --- compiler/GHC/Hs/Lit.hs | 3 +- compiler/basicTypes/PatSyn.hs | 1 + compiler/coreSyn/CoreLint.hs | 2 +- compiler/coreSyn/PprCore.hs | 2 +- compiler/deSugar/DsExpr.hs | 1 + compiler/ghc.cabal.in | 1 - compiler/ghci/ByteCodeGen.hs | 2 +- compiler/iface/IfaceType.hs | 4 +- compiler/main/DynamicLoading.hs | 3 +- compiler/main/GHC.hs | 1 + compiler/main/PprTyThing.hs | 5 +- compiler/parser/Parser.y | 1 - compiler/rename/RnNames.hs | 1 + compiler/simplCore/SimplUtils.hs | 1 + compiler/typecheck/Constraint.hs | 1 + compiler/typecheck/FamInst.hs | 2 +- compiler/typecheck/FunDeps.hs | 1 + compiler/typecheck/Inst.hs | 1 + compiler/typecheck/TcDeriv.hs | 1 + compiler/typecheck/TcDerivInfer.hs | 1 + compiler/typecheck/TcDerivUtils.hs | 1 + compiler/typecheck/TcErrors.hs | 1 + compiler/typecheck/TcExpr.hs | 1 + compiler/typecheck/TcFlatten.hs | 1 + compiler/typecheck/TcHsSyn.hs | 1 + compiler/typecheck/TcHsType.hs | 1 + compiler/typecheck/TcMType.hs | 1 + compiler/typecheck/TcPat.hs | 2 +- compiler/typecheck/TcSMonad.hs | 1 - compiler/typecheck/TcTyClsDecls.hs | 1 + compiler/typecheck/TcType.hs | 3 +- compiler/typecheck/TcUnify.hs | 1 + compiler/typecheck/TcValidity.hs | 1 + compiler/types/Kind.hs | 97 ------------------- compiler/types/TyCoPpr.hs | 36 ++++++- compiler/types/TyCoRep.hs | 87 ----------------- compiler/types/TyCoRep.hs-boot | 4 - compiler/types/Type.hs | 193 +++++++++++++++++++++++++++++-------- compiler/types/Type.hs-boot | 2 + utils/haddock | 2 +- 40 files changed, 225 insertions(+), 247 deletions(-) delete mode 100644 compiler/types/Kind.hs diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 963bf0e2c0..d6c948edac 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -23,7 +23,8 @@ import GhcPrelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, - negateFractionalLit,SourceText(..),pprWithSourceText ) + negateFractionalLit,SourceText(..),pprWithSourceText, + PprPrec(..), topPrec ) import Type import Outputable import FastString diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 14a05b3258..dddcb51319 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -27,6 +27,7 @@ module PatSyn ( import GhcPrelude import Type +import TyCoPpr import Name import Outputable import Unique diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 16b34f33dc..56921ac434 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -46,12 +46,12 @@ import PprCore import ErrUtils import Coercion import SrcLoc -import Kind import Type import RepType import TyCoRep -- checks validity of types/coercions import TyCoSubst import TyCoFVs +import TyCoPpr ( pprTyVar ) import TyCon import CoAxiom import BasicTypes diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 5fe033b862..c959fc1c4e 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -27,7 +27,7 @@ import IdInfo import Demand import DataCon import TyCon -import Type +import TyCoPpr import Coercion import DynFlags import BasicTypes diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index cfb799e05f..d0409ffd71 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -49,6 +49,7 @@ import MkId import Module import ConLike import DataCon +import TyCoPpr( pprWithTYPE ) import TysWiredIn import PrelNames import BasicTypes diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 7e9171adc9..a33edcd2ea 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -536,7 +536,6 @@ Library InstEnv TyCon CoAxiom - Kind Type TyCoRep TyCoFVs diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index b7b0d95217..fb60c21f9d 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -38,12 +38,12 @@ import PrimOp import CoreFVs import Type import RepType -import Kind ( isLiftedTypeKind ) import DataCon import TyCon import Util import VarSet import TysPrim +import TyCoPpr ( pprType ) import ErrUtils import Unique import FastString diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 09e7c1a3a8..37355a1329 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -63,7 +63,7 @@ import GhcPrelude import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon , liftedRepDataConTyCon, tupleTyConName ) -import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy ) +import {-# SOURCE #-} Type ( isRuntimeRepTy ) import DynFlags import TyCon hiding ( pprPromotionQuote ) @@ -964,7 +964,7 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty go in_kind _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars - | in_kind && TyCoRep.isRuntimeRepTy (tyVarKind tv) + | in_kind && Type.isRuntimeRepTy (tyVarKind tv) = IfaceTyConApp liftedRep IA_Nil | otherwise = ty diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index c4d370cca0..265cef390b 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -39,7 +39,8 @@ import PrelNames ( pluginTyConName, frontendPluginTyConName ) import HscTypes import GHCi.RemoteTypes ( HValue ) -import Type ( Type, eqType, mkTyConTy, pprTyThingCategory ) +import Type ( Type, eqType, mkTyConTy ) +import TyCoPpr ( pprTyThingCategory ) import TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) import Id ( idType ) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d35adf8f4f..53c7680302 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -321,6 +321,7 @@ import TcType import Id import TysPrim ( alphaTyVars ) import TyCon +import TyCoPpr ( pprForAll ) import Class import DataCon import Name hiding ( varName ) diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index b1ed2b2059..4e49b6c661 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -21,15 +21,14 @@ module PprTyThing ( import GhcPrelude -import Type ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll ) +import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) import MkIface ( tyThingToIfaceDecl ) -import Type ( tidyOpenType ) import FamInstEnv( FamInst(..), FamFlavor(..) ) -import Type( Type, pprTypeApp, pprSigmaType ) +import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) import Name import VarEnv( emptyTidyEnv ) import Outputable diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index af2bf8fba2..5fea8646a4 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -70,7 +70,6 @@ import BasicTypes -- compiler/types import Type ( funTyCon ) -import Kind ( Kind ) import Class ( FunDep ) -- compiler/parser diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index bb7de4e3dd..8d1083a547 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -32,6 +32,7 @@ module RnNames ( import GhcPrelude import DynFlags +import TyCoPpr import GHC.Hs import TcEnv import RnEnv diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index eb57720d9e..5073bbff99 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -46,6 +46,7 @@ import DynFlags import CoreSyn import qualified CoreSubst import PprCore +import TyCoPpr ( pprParendType ) import CoreFVs import CoreUtils import CoreArity diff --git a/compiler/typecheck/Constraint.hs b/compiler/typecheck/Constraint.hs index b518acfc46..700c024a0d 100644 --- a/compiler/typecheck/Constraint.hs +++ b/compiler/typecheck/Constraint.hs @@ -92,6 +92,7 @@ import TcOrigin import CoreSyn +import TyCoPpr import OccName import FV import VarSet diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index c91b991ea8..213064d599 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -34,9 +34,9 @@ import Util import RdrName import DataCon ( dataConName ) import Maybes -import Type import TyCoRep import TyCoFVs +import TyCoPpr ( pprWithExplicitKindsWhen ) import TcMType import Name import Panic diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index 809e42883a..30c848a7d5 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -33,6 +33,7 @@ import InstEnv import VarSet import VarEnv import TyCoFVs +import TyCoPpr( pprWithExplicitKindsWhen ) import FV import Outputable import ErrUtils( Validity(..), allValid ) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index cab0e596c5..4489482459 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -54,6 +54,7 @@ import FunDeps import TcMType import Type import TyCoRep +import TyCoPpr ( debugPprType ) import TcType import HscTypes import Class( Class ) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 11232e624e..a6c44d0c45 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -35,6 +35,7 @@ import Inst import FamInstEnv import TcHsType import TyCoRep +import TyCoPpr ( pprTyVars ) import RnNames( extendGlobalRdrEnvRn ) import RnBinds diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 3187122828..97dffcd1cf 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -36,6 +36,7 @@ import Constraint import Predicate import TcType import TyCon +import TyCoPpr (pprTyVars) import Type import TcSimplify import TcValidity (validDerivPred) diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index 8defda4128..9005f738a4 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -49,6 +49,7 @@ import TcRnMonad import TcType import THNames (liftClassKey) import TyCon +import TyCoPpr (pprSourceTyCon) import Type import Util import VarSet diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 62117bc756..ffc054ee0a 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -25,6 +25,7 @@ import TcOrigin import RnUnbound ( unknownNameSuggestions ) import Type import TyCoRep +import TyCoPpr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) import Unify ( tcMatchTys ) import Module import FamInst diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 3c827fba59..b7a6779325 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -58,6 +58,7 @@ import NameSet import RdrName import TyCon import TyCoRep +import TyCoPpr import TyCoSubst (substTyWithInScope) import Type import TcEvidence diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 5cc2f897bb..fed20bf810 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -13,6 +13,7 @@ module TcFlatten( import GhcPrelude import TcRnTypes +import TyCoPpr ( pprTyVar ) import Constraint import Predicate import TcType diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 601433b99d..e8b67bbc89 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -59,6 +59,7 @@ import TcType import TcMType import TcEnv ( tcLookupGlobalOnly ) import TcEvidence +import TyCoPpr ( pprTyVar ) import TysPrim import TyCon import TysWiredIn diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 82cc6e2002..4ed472386c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -83,6 +83,7 @@ import TcIface import TcSimplify import TcHsSyn import TyCoRep +import TyCoPpr import TcErrors ( reportAllUnsolved ) import TcType import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index d64a911550..bb6f2b4dc2 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -94,6 +94,7 @@ module TcMType ( import GhcPrelude import TyCoRep +import TyCoPpr import TcType import Type import TyCon diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 39e6dcd3dd..6d68cd5904 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -33,7 +33,7 @@ import RdrName import TcEnv import TcMType import TcValidity( arityErr ) -import Type ( pprTyVars ) +import TyCoPpr ( pprTyVars ) import TcType import TcUnify import TcHsType diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 2d925641b7..59f9b45617 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -140,7 +140,6 @@ import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) ) import qualified TcEnv as TcM ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -import Kind import TcType import DynFlags import Type diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 80e220d385..9a81e35e06 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -50,6 +50,7 @@ import Coercion import TcOrigin import Type import TyCoRep -- for checkValidRoles +import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen ) import Class import CoAxiom import TyCon diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index e81e3e8edb..1537859d1b 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -192,11 +192,10 @@ module TcType ( -- friends: import GhcPrelude -import Kind import TyCoRep import TyCoSubst ( mkTvSubst, substTyWithCoVars ) import TyCoFVs -import TyCoPpr ( pprParendTheta ) +import TyCoPpr import Class import Var import ForeignCall diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 819cc0c2ee..44842e43ae 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -42,6 +42,7 @@ import GhcPrelude import GHC.Hs import TyCoRep +import TyCoPpr( debugPprType ) import TcMType import TcRnMonad import TcType diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index b882f88828..f02cb887cf 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -29,6 +29,7 @@ import TcSimplify ( simplifyAmbiguityCheck ) import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) import TyCoFVs import TyCoRep +import TyCoPpr import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) import PrelNames diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs deleted file mode 100644 index f59d23e1dc..0000000000 --- a/compiler/types/Kind.hs +++ /dev/null @@ -1,97 +0,0 @@ --- (c) The University of Glasgow 2006-2012 - -{-# LANGUAGE CPP #-} -module Kind ( - -- * Main data type - Kind, - - -- ** Predicates on Kinds - isLiftedTypeKind, isUnliftedTypeKind, - isConstraintKindCon, - - classifiesTypeWithValues, - isKindLevPoly - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} Type ( coreView ) - -import TyCoRep -import TyCon -import PrelNames - -import Outputable -import Util -import Data.Maybe( isJust ) - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and Type. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have Type. -See #7451. - -Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - -isConstraintKindCon :: TyCon -> Bool -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - --- | Tests whether the given kind (which should look like @TYPE x@) --- is something other than a constructor tree (that is, constructors at every node). --- E.g. True of TYPE k, TYPE (F Int) --- False of TYPE 'LiftedRep -isKindLevPoly :: Kind -> Bool -isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) - -- the isLiftedTypeKind check is necessary b/c of Constraint - go k - where - go ty | Just ty' <- coreView ty = go ty' - go TyVarTy{} = True - go AppTy{} = True -- it can't be a TyConApp - go (TyConApp tc tys) = isFamilyTyCon tc || any go tys - go ForAllTy{} = True - go (FunTy _ t1 t2) = go t1 || go t2 - go LitTy{} = False - go CastTy{} = True - go CoercionTy{} = True - - _is_type = classifiesTypeWithValues k - ------------------------------------------ --- Subkinding --- The tc variants are used during type-checking, where ConstraintKind --- is distinct from all other kinds --- After type-checking (in core), Constraint and liftedTypeKind are --- indistinguishable - --- | Does this classify a type allowed to have values? Responds True to things --- like *, #, TYPE Lifted, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues k = isJust (kindRep_maybe k) diff --git a/compiler/types/TyCoPpr.hs b/compiler/types/TyCoPpr.hs index 1dfde74dd2..e46b299cc5 100644 --- a/compiler/types/TyCoPpr.hs +++ b/compiler/types/TyCoPpr.hs @@ -1,7 +1,10 @@ -- | Pretty-printing types and coercions. module TyCoPpr ( - -- * Pretty-printing + -- * Precedence + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + -- * Pretty-printing types pprType, pprParendType, pprPrecType, pprPrecTypeX, pprTypeApp, pprTCvBndr, pprTCvBndrs, pprSigmaType, @@ -9,12 +12,17 @@ module TyCoPpr pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, pprDataCons, pprWithExplicitKindsWhen, + pprWithTYPE, pprSourceTyCon, + + -- * Pretty-printing coercions pprCo, pprParendCo, debugPprType, + + -- * Pretty-printing 'TyThing's + pprTyThingCategory, pprShortTyThing, ) where import GhcPrelude @@ -25,6 +33,8 @@ import {-# SOURCE #-} DataCon( dataConFullSig , dataConUserTyVarBinders , DataCon ) +import {-# SOURCE #-} Type( isLiftedTypeKind ) + import TyCon import TyCoRep import TyCoTidy @@ -37,7 +47,8 @@ import IfaceType import VarSet import VarEnv -import DynFlags ( gopt_set, GeneralFlag(Opt_PrintExplicitKinds) ) +import DynFlags ( gopt_set, + GeneralFlag(Opt_PrintExplicitKinds, Opt_PrintExplicitRuntimeReps) ) import Outputable import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec , funPrec, appPrec, maybeParen ) @@ -305,3 +316,22 @@ pprWithExplicitKindsWhen b = updSDocDynFlags $ \dflags -> if b then gopt_set dflags Opt_PrintExplicitKinds else dflags + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ + ppr ty + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 065efcd417..be2f74c731 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -14,8 +14,6 @@ Note [The Type-related module hierarchy] TyCoSubst imports TyCoRep, TyCoFVs, TyCoPpr TyCoTidy imports TyCoRep, TyCoFVs TysPrim imports TyCoRep ( including mkTyConTy ) - Kind imports TysPrim ( mainly for primitive kinds ) - Type imports Kind Coercion imports Type -} @@ -52,12 +50,6 @@ module TyCoRep ( mkForAllTy, mkForAllTys, mkPiTy, mkPiTys, - kindRep_maybe, kindRep, - isLiftedTypeKind, isUnliftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, - isRuntimeRepTy, isRuntimeRepVar, - sameVis, - -- * Functions over binders TyCoBinder(..), TyCoVarBinder, TyBinder, binderVar, binderVars, binderType, binderArgFlag, @@ -77,7 +69,6 @@ module TyCoRep ( import GhcPrelude -import {-# SOURCE #-} Type( coreView ) import {-# SOURCE #-} TyCoPpr ( pprType, pprCo, pprTyLit ) -- Transitively pulls in a LOT of stuff, better to break the loop @@ -94,7 +85,6 @@ import CoAxiom -- others import BasicTypes ( LeftOrRight(..), pickLR ) -import PrelNames import Outputable import FastString import Util @@ -960,83 +950,6 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs mkTyConTy :: TyCon -> Type mkTyConTy tycon = TyConApp tycon [] -{- -Some basic functions, put here to break loops eg with the pretty printer --} - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -kindRep k = case kindRep_maybe k of - Just r -> r - Nothing -> pprPanic "kindRep" (ppr k) - --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. --- For example, @kindRep_maybe * = Just LiftedRep@ --- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same -kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -kindRep_maybe kind - | Just kind' <- coreView kind = kindRep_maybe kind' - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - --- | Returns True if the kind classifies unlifted types and False otherwise. --- Note that this returns False for levity-polymorphic kinds, which may --- be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - -isLiftedRuntimeRep :: Type -> Bool --- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep --- False of type variables (a :: RuntimeRep) --- and of other reps e.g. (IntRep :: RuntimeRep) -isLiftedRuntimeRep rep - | Just rep' <- coreView rep = isLiftedRuntimeRep rep' - | TyConApp rr_tc args <- rep - , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True - | otherwise = False - -isUnliftedRuntimeRep :: Type -> Bool --- True of definitely-unlifted RuntimeReps --- False of (LiftedRep :: RuntimeRep) --- and of variables (a :: RuntimeRep) -isUnliftedRuntimeRep rep - | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' - | TyConApp rr_tc _ <- rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] - = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep - | otherwise {- Variables, applications -} - = False - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc args) - | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True -isRuntimeRepTy _ = False - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - {- %************************************************************************ %* * diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 8f1d0ad526..0050dcd26b 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -1,7 +1,5 @@ module TyCoRep where -import GhcPrelude - import Data.Data ( Data ) import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) @@ -22,6 +20,4 @@ type MCoercionN = MCoercion mkFunTy :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type -isRuntimeRepTy :: Type -> Bool - instance Data Type -- To support Data instances in CoAxiom diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 44d18aff9a..f91b7caf88 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -79,7 +79,7 @@ module Type ( modifyJoinResTy, setJoinResTy, - -- Analyzing types + -- ** Analyzing types TyCoMapper(..), mapType, mapCoercion, -- (Newtypes) @@ -112,8 +112,11 @@ module Type ( isValidJoinPointType, tyConAppNeedsKindSig, - -- (Lifting and boxity) - isLiftedType_maybe, isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, + -- *** Levity and boxity + isLiftedType_maybe, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType, isAlgType, isDataFamilyAppType, isPrimitiveType, isStrictType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, @@ -194,17 +197,6 @@ module Type ( substVarBndr, substVarBndrs, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - -- * Pretty-printing - pprType, pprParendType, pprPrecType, - pprTypeApp, pprTyThingCategory, pprShortTyThing, - pprTCvBndr, pprTCvBndrs, pprForAll, pprUserForAll, - pprSigmaType, pprWithExplicitKindsWhen, - pprTheta, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, pprSourceTyCon, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, - pprTyVar, pprTyVars, debugPprType, - pprWithTYPE, - -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, @@ -214,7 +206,12 @@ module Type ( tidyTyCoVarOcc, tidyTopType, tidyKind, - tidyTyCoVarBinder, tidyTyCoVarBinders + tidyTyCoVarBinder, tidyTyCoVarBinders, + + -- * Kinds + isConstraintKindCon, + classifiesTypeWithValues, + isKindLevPoly ) where #include "HsVersions.h" @@ -226,11 +223,9 @@ import BasicTypes -- We import the representation and primitive functions from TyCoRep. -- Many things are reexported, but not the representation! -import Kind import TyCoRep import TyCoSubst import TyCoTidy -import TyCoPpr import TyCoFVs -- friends: @@ -260,7 +255,6 @@ import FV import Outputable import FastString import Pair -import DynFlags ( gopt_set, GeneralFlag(Opt_PrintExplicitRuntimeReps) ) import ListSetOps import Unique ( nonDetCmpUnique ) @@ -479,6 +473,81 @@ expandTypeSynonyms ty -- order of a coercion) go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | Just kind' <- coreView kind = kindRep_maybe kind' + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | Just rep' <- coreView rep = isLiftedRuntimeRep rep' + | TyConApp rr_tc args <- rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' + | TyConApp rr_tc _ <- rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc args) + | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True +isRuntimeRepTy _ = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + + {- ************************************************************************ * * @@ -1845,19 +1914,6 @@ coAxNthLHS :: CoAxiom br -> Int -> Type coAxNthLHS ax ind = mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon - isFamFreeTy :: Type -> Bool isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' isFamFreeTy (TyVarTy _) = True @@ -2804,6 +2860,74 @@ setJoinResTy :: Int -- Number of binders to skip setJoinResTy ar new_res_ty ty = modifyJoinResTy ar (const new_res_ty) ty +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and Type. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + C a ~ (a -> a) +so on the left we have Constraint, and on the right we have Type. +See #7451. + +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. +-} + +isConstraintKindCon :: TyCon -> Bool +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey + +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +-- E.g. True of TYPE k, TYPE (F Int) +-- False of TYPE 'LiftedRep +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreView ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy _ t1 t2) = go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type = classifiesTypeWithValues k + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +classifiesTypeWithValues k = isJust (kindRep_maybe k) {- %************************************************************************ @@ -2816,13 +2940,6 @@ Most pretty-printing is either in TyCoRep or IfaceType. -} --- | This variant preserves any use of TYPE in a type, effectively --- locally setting -fprint-explicit-runtime-reps. -pprWithTYPE :: Type -> SDoc -pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ - ppr ty - - -- | Does a 'TyCon' (that is applied to some number of arguments) need to be -- ascribed with an explicit kind signature to resolve ambiguity if rendered as -- a source-syntax type? diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 446c9d989d..16c6bfe07b 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -18,6 +18,8 @@ eqType :: Type -> Type -> Bool coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type +isRuntimeRepTy :: Type -> Bool +isLiftedTypeKind :: Type -> Bool splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) diff --git a/utils/haddock b/utils/haddock index b34ca2554a..e3c045f926 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit b34ca2554a3440f092f585bb7fc1e9d4b2ca8616 +Subproject commit e3c045f9265e39c1a77aa003bf35785e1871a9d5 -- cgit v1.2.1