-- ; return $ Vect v (Just rhs')
-- }
\end{code}
+
+
+
+\begin{code}
+--
+-- Simplification routines run before the flattener. We can't use
+-- simpleOptPgm -- it doesn't preserve the order of subexpressions or
+-- let-binding groups.
+--
+simplify :: Expr CoreBndr -> Expr CoreBndr
+simplify (Var v) = Var v
+simplify (App e1 e2) = App (simplify e1) (simplify e2)
+simplify (Lit lit) = Lit lit
+simplify (Note note e) = Note note (simplify e)
+simplify (Cast e co) = if tcEqType (fst $ coercionKind co) (snd $ coercionKind co)
+ then simplify e
+ else Cast (simplify e) co
+simplify (Lam v e) = Lam v (simplify e)
+simplify (Type t) = Type t
+simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
+simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
+
+simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
+simplifyBind (NonRec b e) = [NonRec b (simplify e)]
+simplifyBind (Rec []) = []
+simplifyBind (Rec (rbs@((b,e):rbs'))) =
+ if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
+ then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
+ else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
+
+simplifyBinds = concatMap simplifyBind
- \end{code}
++\end{code}
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _ (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
- ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
- ( "RecursiveDo", Opt_RecursiveDo,
+ ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
- ( "DoRec", Opt_DoRec, nop ),
+ ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
+ ( "ModalTypes", Opt_ModalTypes, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
alr_last_loc = noSrcSpan,
alr_context = [],
alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
+ alr_justClosedExplicitLetBlock = False,
+ code_type_bracket_depth = 0
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
- .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
- .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
- .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` xopt Opt_DoRec flags
- .|. recBit `setBitIf` xopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
++ .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
+ .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
- .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM,
+ gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
+ gHC_HETMET_CODETYPES,
+ gHC_HETMET_PRIVATE,
+ gHC_HETMET_GARROW,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
stringTyConKey :: Unique
stringTyConKey = mkPreludeTyConUnique 134
- -- Heterogeneous Metaprogramming code type constructor
- hetMetCodeTypeTyConKey :: Unique
- hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
+ -- Generics (Unique keys)
+ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
+ k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
+ compTyConKey, rTyConKey, pTyConKey, dTyConKey,
+ cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+ d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
+ repTyConKey, rep1TyConKey :: Unique
+
+ v1TyConKey = mkPreludeTyConUnique 135
+ u1TyConKey = mkPreludeTyConUnique 136
+ par1TyConKey = mkPreludeTyConUnique 137
+ rec1TyConKey = mkPreludeTyConUnique 138
+ k1TyConKey = mkPreludeTyConUnique 139
+ m1TyConKey = mkPreludeTyConUnique 140
+
+ sumTyConKey = mkPreludeTyConUnique 141
+ prodTyConKey = mkPreludeTyConUnique 142
+ compTyConKey = mkPreludeTyConUnique 143
+
+ rTyConKey = mkPreludeTyConUnique 144
+ pTyConKey = mkPreludeTyConUnique 145
+ dTyConKey = mkPreludeTyConUnique 146
+ cTyConKey = mkPreludeTyConUnique 147
+ sTyConKey = mkPreludeTyConUnique 148
+
+ rec0TyConKey = mkPreludeTyConUnique 149
+ par0TyConKey = mkPreludeTyConUnique 150
+ d1TyConKey = mkPreludeTyConUnique 151
+ c1TyConKey = mkPreludeTyConUnique 152
+ s1TyConKey = mkPreludeTyConUnique 153
+ noSelTyConKey = mkPreludeTyConUnique 154
+
+ repTyConKey = mkPreludeTyConUnique 155
+ rep1TyConKey = mkPreludeTyConUnique 156
++>>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
toIntegerClassOpKey = mkPreludeMiscIdUnique 129
toRationalClassOpKey = mkPreludeMiscIdUnique 130
+ -- Monad comprehensions
+ guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique
+ guardMIdKey = mkPreludeMiscIdUnique 131
+ liftMIdKey = mkPreludeMiscIdUnique 132
+ groupMIdKey = mkPreludeMiscIdUnique 133
+ mzipIdKey = mkPreludeMiscIdUnique 134
+
+-- code types
- hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
- hetmet_brak_key = mkPreludeMiscIdUnique 131
- hetmet_esc_key = mkPreludeMiscIdUnique 132
- hetmet_csp_key = mkPreludeMiscIdUnique 133
++hetMetCodeTypeTyConKey :: Unique
++hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
++
+hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique
+hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
+hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135
+hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136
+hetmet_PGArrow_key :: Unique
+hetmet_PGArrow_key = mkPreludeMiscIdUnique 137
+hetmet_pga_id_key :: Unique
+hetmet_pga_id_key = mkPreludeMiscIdUnique 138
+hetmet_pga_comp_key :: Unique
+hetmet_pga_comp_key = mkPreludeMiscIdUnique 139
+hetmet_pga_first_key :: Unique
+hetmet_pga_first_key = mkPreludeMiscIdUnique 140
+hetmet_pga_second_key :: Unique
+hetmet_pga_second_key = mkPreludeMiscIdUnique 141
+hetmet_pga_cancell_key :: Unique
+hetmet_pga_cancell_key = mkPreludeMiscIdUnique 142
+hetmet_pga_cancelr_key :: Unique
+hetmet_pga_cancelr_key = mkPreludeMiscIdUnique 143
+hetmet_pga_uncancell_key :: Unique
+hetmet_pga_uncancell_key = mkPreludeMiscIdUnique 144
+hetmet_pga_uncancelr_key :: Unique
+hetmet_pga_uncancelr_key = mkPreludeMiscIdUnique 145
+hetmet_pga_assoc_key :: Unique
+hetmet_pga_assoc_key = mkPreludeMiscIdUnique 146
+hetmet_pga_unassoc_key :: Unique
+hetmet_pga_unassoc_key = mkPreludeMiscIdUnique 147
+hetmet_pga_copy_key :: Unique
+hetmet_pga_copy_key = mkPreludeMiscIdUnique 148
+hetmet_pga_drop_key :: Unique
+hetmet_pga_drop_key = mkPreludeMiscIdUnique 149
+hetmet_pga_swap_key :: Unique
+hetmet_pga_swap_key = mkPreludeMiscIdUnique 150
+hetmet_pga_applyl_key :: Unique
+hetmet_pga_applyl_key = mkPreludeMiscIdUnique 151
+hetmet_pga_applyr_key :: Unique
+hetmet_pga_applyr_key = mkPreludeMiscIdUnique 152
+hetmet_pga_curryl_key :: Unique
+hetmet_pga_curryl_key = mkPreludeMiscIdUnique 153
+hetmet_pga_curryr_key :: Unique
+hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154
+hetmet_flatten_key = mkPreludeMiscIdUnique 155
+hetmet_unflatten_key = mkPreludeMiscIdUnique 156
+hetmet_flattened_id_key = mkPreludeMiscIdUnique 157
+hetmet_PGArrow_unit_key :: Unique
+hetmet_PGArrow_unit_key = mkPreludeMiscIdUnique 158
+hetmet_PGArrow_tensor_key :: Unique
+hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159
+hetmet_PGArrow_exponent_key :: Unique
+hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160
+
++hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
++hetmet_brak_key = mkPreludeMiscIdUnique 161
++hetmet_esc_key = mkPreludeMiscIdUnique 162
++hetmet_csp_key = mkPreludeMiscIdUnique 163
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
import Var ( TyVar, mkTyVar )
import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
- import OccName ( mkTcOcc )
- import OccName ( mkTyVarOccFS, mkTcOccFS )
- import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
+ import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+ import TyCon
+ import TypeRep
+import Type
- import TypeRep ( ecKind )
+import Coercion
import SrcLoc
import Unique ( mkAlphaTyVarUnique )
import PrelNames
, intTyCon
, listTyCon
, parrTyCon
+ , hetMetCodeTypeTyCon
- , unsafeCoercionTyCon
- , symCoercionTyCon
- , transCoercionTyCon
- , leftCoercionTyCon
- , rightCoercionTyCon
- , instCoercionTyCon
]
\end{code}
isPArrFakeCon :: DataCon -> Bool
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
\end{code}
+
-
+Heterogeneous Metaprogramming
+
+\begin{code}
+-- | Construct a type representing the application of the box type
+mkHetMetCodeTypeTy :: TyVar -> Type -> Type
+mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty]
+
+ecTyVar = head ecTyVars
+
+-- | Represents the type constructor of box types
+hetMetCodeTypeTyCon :: TyCon
+hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon]
+
+-- | Check whether a type constructor is the constructor for box types
+isHetMetCodeTypeTyCon :: TyCon -> Bool
+isHetMetCodeTypeTyCon tc = tyConName tc == hetMetCodeTypeTyConName
+
+hetMetCodeTypeDataCon :: DataCon
+hetMetCodeTypeDataCon = pcDataCon
+ hetMetCodeTypeDataConName
+ [betaTyVar] -- forall'ed type variables
+ [betaTy]
+ hetMetCodeTypeTyCon
+
+\end{code}
ty' <- kcLiftedType ty
return (HsPArrTy ty', liftedTypeKind)
+kc_hs_type (HsModalBoxType ecn ty) = do
+ kc_check_hs_type (HsTyVar ecn) (EK ecKind EkUnk)
+ ty' <- kcLiftedType ty
+ return (HsModalBoxType ecn ty', liftedTypeKind)
+
- kc_hs_type (HsNumTy n)
- = return (HsNumTy n, liftedTypeKind)
-
kc_hs_type (HsKindSig ty k) = do
ty' <- kc_check_lhs_type ty (EK k EkKindSig)
return (HsKindSig ty' k, k)
--- /dev/null
+ %
+ % (c) The University of Glasgow 2006
+ %
+
+ \begin{code}
+ module Kind (
+ -- * Main data type
+ Kind, typeKind,
+
+ -- Kinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+ mkArrowKind, mkArrowKinds,
+
+ -- Kind constructors...
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
++ ecKind,
+
+ -- Super Kinds
+ tySuperKind, tySuperKindTyCon,
+
+ pprKind, pprParendKind,
+
+ -- ** Deconstructing Kinds
+ kindFunResult, kindAppResult, synTyConResKind,
+ splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
+
+ -- ** Predicates on Kinds
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
+ isSuperKind, isCoercionKind,
+ isLiftedTypeKindCon,
+
+ isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
+ isSubKindCon,
+
+ ) where
+
+ #include "HsVersions.h"
+
+ import TypeRep
+ import TysPrim
+ import TyCon
+ import Var
+ import PrelNames
+ import Outputable
+ \end{code}
+
+ %************************************************************************
+ %* *
+ Predicates over Kinds
+ %* *
+ %************************************************************************
+
+ \begin{code}
+ isTySuperKind :: SuperKind -> Bool
+ isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
+ isTySuperKind _ = False
+
+ -------------------
+ -- Lastly we need a few functions on Kinds
+
+ isLiftedTypeKindCon :: TyCon -> Bool
+ isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
+ \end{code}
+
+ %************************************************************************
+ %* *
+ The kind of a type
+ %* *
+ %************************************************************************
+
+ \begin{code}
+ typeKind :: Type -> Kind
+ typeKind _ty@(TyConApp tc tys)
+ = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty )
+ -- Assertion checks for unsaturated application of (~)
+ -- See Note [The (~) TyCon] in TysPrim
+ kindAppResult (tyConKind tc) tys
+
+ typeKind (PredTy pred) = predKind pred
+ typeKind (AppTy fun _) = kindFunResult (typeKind fun)
+ typeKind (ForAllTy _ ty) = typeKind ty
+ typeKind (TyVarTy tyvar) = tyVarKind tyvar
+ typeKind (FunTy _arg res)
+ -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
+ -- not unliftedTypKind (#)
+ -- The only things that can be after a function arrow are
+ -- (a) types (of kind openTypeKind or its sub-kinds)
+ -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
+ | isTySuperKind k = k
+ | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
+ where
+ k = typeKind res
+
+ ------------------
+ predKind :: PredType -> Kind
+ predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted
+ predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are
+ predKind (IParam {}) = liftedTypeKind -- always represented by lifted types
+ \end{code}
+
+ %************************************************************************
+ %* *
+ Functions over Kinds
+ %* *
+ %************************************************************************
+
+ \begin{code}
+ -- | Essentially 'funResultTy' on kinds
+ kindFunResult :: Kind -> Kind
+ kindFunResult (FunTy _ res) = res
+ kindFunResult k = pprPanic "kindFunResult" (ppr k)
+
+ kindAppResult :: Kind -> [arg] -> Kind
+ kindAppResult k [] = k
+ kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+
+ -- | Essentially 'splitFunTys' on kinds
+ splitKindFunTys :: Kind -> ([Kind],Kind)
+ splitKindFunTys (FunTy a r) = case splitKindFunTys r of
+ (as, k) -> (a:as, k)
+ splitKindFunTys k = ([], k)
+
+ splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
+ splitKindFunTy_maybe (FunTy a r) = Just (a,r)
+ splitKindFunTy_maybe _ = Nothing
+
+ -- | Essentially 'splitFunTysN' on kinds
+ splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
+ splitKindFunTysN 0 k = ([], k)
+ splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of
+ (as, k) -> (a:as, k)
+ splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
+
+ -- | Find the result 'Kind' of a type synonym,
+ -- after applying it to its 'arity' number of type variables
+ -- Actually this function works fine on data types too,
+ -- but they'd always return '*', so we never need to ask
+ synTyConResKind :: TyCon -> Kind
+ synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+
+ -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+ isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
+ isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
+ isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
+
+ isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
+
+ isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
+ isOpenTypeKind _ = False
+
+ isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
+
+ isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
+ isUbxTupleKind _ = False
+
+ isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
+
+ isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
+ isArgTypeKind _ = False
+
+ isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
+
+ isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
+ isUnliftedTypeKind _ = False
+
+ isSubOpenTypeKind :: Kind -> Bool
+ -- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
+ isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
+ ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
+ False
+ isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
+ isSubOpenTypeKind other = ASSERT( isKind other ) False
+ -- This is a conservative answer
+ -- It matters in the call to isSubKind in
+ -- checkExpectedKind.
+
+ isSubArgTypeKindCon kc
+ | isUnliftedTypeKindCon kc = True
+ | isLiftedTypeKindCon kc = True
+ | isArgTypeKindCon kc = True
+ | otherwise = False
+
+ isSubArgTypeKind :: Kind -> Bool
+ -- ^ True of any sub-kind of ArgTypeKind
+ isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
+ isSubArgTypeKind _ = False
+
+ -- | Is this a super-kind (i.e. a type-of-kinds)?
+ isSuperKind :: Type -> Bool
+ isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
+ isSuperKind _ = False
+
+ -- | Is this a kind (i.e. a type-of-types)?
+ isKind :: Kind -> Bool
+ isKind k = isSuperKind (typeKind k)
+
+ isSubKind :: Kind -> Kind -> Bool
+ -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
+ isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
+ isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+ isSubKind _ _ = False
+
+ isSubKindCon :: TyCon -> TyCon -> Bool
+ -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
+ isSubKindCon kc1 kc2
+ | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
+ | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
+ | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
+ | isOpenTypeKindCon kc2 = True
+ -- we already know kc1 is not a fun, its a TyCon
+ | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
+ | otherwise = False
+
+ defaultKind :: Kind -> Kind
+ -- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
+ -- information on what that means
+
+ -- When we generalise, we make generic type variables whose kind is
+ -- simple (* or *->* etc). So generic type variables (other than
+ -- built-in constants like 'error') always have simple kinds. This is important;
+ -- consider
+ -- f x = True
+ -- We want f to get type
+ -- f :: forall (a::*). a -> Bool
+ -- Not
+ -- f :: forall (a::??). a -> Bool
+ -- because that would allow a call like (f 3#) as well as (f True),
+ --and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
+ defaultKind k
+ | isSubOpenTypeKind k = liftedTypeKind
+ | isSubArgTypeKind k = liftedTypeKind
+ | otherwise = k
++
++ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
+ \end{code}
projects / ghc-hetmet.git / commitdiff