Ensure that coreView/tcView are able to inline
authorBen Gamari <ben@smart-cactus.org>
Thu, 7 Nov 2019 19:31:15 +0000 (14:31 -0500)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Wed, 13 Nov 2019 12:06:49 +0000 (07:06 -0500)
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

40 files changed:
compiler/GHC/Hs/Lit.hs
compiler/basicTypes/PatSyn.hs
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/PprCore.hs
compiler/deSugar/DsExpr.hs
compiler/ghc.cabal.in
compiler/ghci/ByteCodeGen.hs
compiler/iface/IfaceType.hs
compiler/main/DynamicLoading.hs
compiler/main/GHC.hs
compiler/main/PprTyThing.hs
compiler/parser/Parser.y
compiler/rename/RnNames.hs
compiler/simplCore/SimplUtils.hs
compiler/typecheck/Constraint.hs
compiler/typecheck/FamInst.hs
compiler/typecheck/FunDeps.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivInfer.hs
compiler/typecheck/TcDerivUtils.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/types/Kind.hs [deleted file]
compiler/types/TyCoPpr.hs
compiler/types/TyCoRep.hs
compiler/types/TyCoRep.hs-boot
compiler/types/Type.hs
compiler/types/Type.hs-boot
utils/haddock

index 963bf0e..d6c948e 100644 (file)
@@ -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
index 14a05b3..dddcb51 100644 (file)
@@ -27,6 +27,7 @@ module PatSyn (
 import GhcPrelude
 
 import Type
+import TyCoPpr
 import Name
 import Outputable
 import Unique
index 16b34f3..56921ac 100644 (file)
@@ -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
index 5fe033b..c959fc1 100644 (file)
@@ -27,7 +27,7 @@ import IdInfo
 import Demand
 import DataCon
 import TyCon
-import Type
+import TyCoPpr
 import Coercion
 import DynFlags
 import BasicTypes
index cfb799e..d0409ff 100644 (file)
@@ -49,6 +49,7 @@ import MkId
 import Module
 import ConLike
 import DataCon
+import TyCoPpr( pprWithTYPE )
 import TysWiredIn
 import PrelNames
 import BasicTypes
index 7e9171a..a33edcd 100644 (file)
@@ -536,7 +536,6 @@ Library
         InstEnv
         TyCon
         CoAxiom
-        Kind
         Type
         TyCoRep
         TyCoFVs
index b7b0d95..fb60c21 100644 (file)
@@ -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
index 09e7c1a..37355a1 100644 (file)
@@ -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
index c4d370c..265cef3 100644 (file)
@@ -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 )
index d35adf8..53c7680 100644 (file)
@@ -321,6 +321,7 @@ import TcType
 import Id
 import TysPrim          ( alphaTyVars )
 import TyCon
+import TyCoPpr          ( pprForAll )
 import Class
 import DataCon
 import Name             hiding ( varName )
index b1ed2b2..4e49b6c 100644 (file)
@@ -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
index af2bf8f..5fea864 100644 (file)
@@ -70,7 +70,6 @@ import BasicTypes
 
 -- compiler/types
 import Type             ( funTyCon )
-import Kind             ( Kind )
 import Class            ( FunDep )
 
 -- compiler/parser
index bb7de4e..8d1083a 100644 (file)
@@ -32,6 +32,7 @@ module RnNames (
 import GhcPrelude
 
 import DynFlags
+import TyCoPpr
 import GHC.Hs
 import TcEnv
 import RnEnv
index eb57720..5073bbf 100644 (file)
@@ -46,6 +46,7 @@ import DynFlags
 import CoreSyn
 import qualified CoreSubst
 import PprCore
+import TyCoPpr          ( pprParendType )
 import CoreFVs
 import CoreUtils
 import CoreArity
index b518acf..700c024 100644 (file)
@@ -92,6 +92,7 @@ import TcOrigin
 
 import CoreSyn
 
+import TyCoPpr
 import OccName
 import FV
 import VarSet
index c91b991..213064d 100644 (file)
@@ -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
index 809e428..30c848a 100644 (file)
@@ -33,6 +33,7 @@ import InstEnv
 import VarSet
 import VarEnv
 import TyCoFVs
+import TyCoPpr( pprWithExplicitKindsWhen )
 import FV
 import Outputable
 import ErrUtils( Validity(..), allValid )
index cab0e59..4489482 100644 (file)
@@ -54,6 +54,7 @@ import FunDeps
 import TcMType
 import Type
 import TyCoRep
+import TyCoPpr     ( debugPprType )
 import TcType
 import HscTypes
 import Class( Class )
index 11232e6..a6c44d0 100644 (file)
@@ -35,6 +35,7 @@ import Inst
 import FamInstEnv
 import TcHsType
 import TyCoRep
+import TyCoPpr    ( pprTyVars )
 
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
index 3187122..97dffcd 100644 (file)
@@ -36,6 +36,7 @@ import Constraint
 import Predicate
 import TcType
 import TyCon
+import TyCoPpr (pprTyVars)
 import Type
 import TcSimplify
 import TcValidity (validDerivPred)
index 8defda4..9005f73 100644 (file)
@@ -49,6 +49,7 @@ import TcRnMonad
 import TcType
 import THNames (liftClassKey)
 import TyCon
+import TyCoPpr (pprSourceTyCon)
 import Type
 import Util
 import VarSet
index 62117bc..ffc054e 100644 (file)
@@ -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
index 3c827fb..b7a6779 100644 (file)
@@ -58,6 +58,7 @@ import NameSet
 import RdrName
 import TyCon
 import TyCoRep
+import TyCoPpr
 import TyCoSubst (substTyWithInScope)
 import Type
 import TcEvidence
index 5cc2f89..fed20bf 100644 (file)
@@ -13,6 +13,7 @@ module TcFlatten(
 import GhcPrelude
 
 import TcRnTypes
+import TyCoPpr       ( pprTyVar )
 import Constraint
 import Predicate
 import TcType
index 601433b..e8b67bb 100644 (file)
@@ -59,6 +59,7 @@ import TcType
 import TcMType
 import TcEnv   ( tcLookupGlobalOnly )
 import TcEvidence
+import TyCoPpr ( pprTyVar )
 import TysPrim
 import TyCon
 import TysWiredIn
index 82cc6e2..4ed4723 100644 (file)
@@ -83,6 +83,7 @@ import TcIface
 import TcSimplify
 import TcHsSyn
 import TyCoRep
+import TyCoPpr
 import TcErrors ( reportAllUnsolved )
 import TcType
 import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )
index d64a911..bb6f2b4 100644 (file)
@@ -94,6 +94,7 @@ module TcMType (
 import GhcPrelude
 
 import TyCoRep
+import TyCoPpr
 import TcType
 import Type
 import TyCon
index 39e6dcd..6d68cd5 100644 (file)
@@ -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
index 2d92564..59f9b45 100644 (file)
@@ -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
index 80e220d..9a81e35 100644 (file)
@@ -50,6 +50,7 @@ import Coercion
 import TcOrigin
 import Type
 import TyCoRep   -- for checkValidRoles
+import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen )
 import Class
 import CoAxiom
 import TyCon
index e81e3e8..1537859 100644 (file)
@@ -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
index 819cc0c..44842e4 100644 (file)
@@ -42,6 +42,7 @@ import GhcPrelude
 
 import GHC.Hs
 import TyCoRep
+import TyCoPpr( debugPprType )
 import TcMType
 import TcRnMonad
 import TcType
index b882f88..f02cb88 100644 (file)
@@ -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 (file)
index f59d23e..0000000
+++ /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)
index 1dfde74..e46b299 100644 (file)
@@ -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
index 065efcd..be2f74c 100644 (file)
@@ -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
@@ -961,83 +951,6 @@ 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
-
-{-
 %************************************************************************
 %*                                                                      *
             Coercions
index 8f1d0ad..0050dcd 100644 (file)
@@ -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
index 44d18af..f91b7ca 100644 (file)
@@ -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?
index 446c9d9..16c6bfe 100644 (file)
@@ -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])
 
index b34ca25..e3c045f 160000 (submodule)
@@ -1 +1 @@
-Subproject commit b34ca2554a3440f092f585bb7fc1e9d4b2ca8616
+Subproject commit e3c045f9265e39c1a77aa003bf35785e1871a9d5