From: Adam Megacz Date: Tue, 31 May 2011 02:34:22 +0000 (-0700) Subject: merge GHC HEAD X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b2524b3960999fffdb3767900f58825903f6560f merge GHC HEAD --- b2524b3960999fffdb3767900f58825903f6560f diff --cc compiler/deSugar/Desugar.lhs index 0e7c032,7b008e9..b2131ca --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@@ -561,35 -406,3 +563,35 @@@ dsVect (L loc (HsVect v rhs) -- ; 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} diff --cc compiler/hsSyn/HsTypes.lhs index def44c5,7dbb16d..7159540 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@@ -441,9 -437,7 +439,8 @@@ ppr_mono_ty _ (HsTupleTy con tys) = 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 diff --cc compiler/main/DynFlags.hs index 6fe6708,d9f3246..7e5dff0 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -1639,11 -1661,10 +1677,11 @@@ xFlags = ( "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 ), diff --cc compiler/parser/Lexer.x index d6b2322,a55a631..4ca0282 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@@ -1899,34 -1868,32 +1897,34 @@@ mkPState flags buf loc 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 diff --cc compiler/prelude/PrelNames.lhs index 76ce5ce,101780d..aa5de15 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@@ -282,11 -274,8 +300,11 @@@ pRELUDE = mkBaseModule_ pRELUDE_NAM 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, @@@ -1174,9 -1206,40 +1294,41 @@@ opaqueTyConKe 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 @@@ -1421,62 -1485,13 +1578,72 @@@ realToFracIdKey = mkPreludeMiscIdU 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 diff --cc compiler/prelude/TysPrim.lhs index a5d9335,d0495d7..4c70bcb --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@@ -54,12 -71,9 +71,11 @@@ module TysPrim 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 diff --cc compiler/prelude/TysWiredIn.lhs index 2f1b637,5a80067..bc45028 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@@ -130,13 -115,6 +121,7 @@@ wiredInTyCons = [ unitTyCon -- Not trea , intTyCon , listTyCon , parrTyCon + , hetMetCodeTypeTyCon - , unsafeCoercionTyCon - , symCoercionTyCon - , transCoercionTyCon - , leftCoercionTyCon - , rightCoercionTyCon - , instCoercionTyCon ] \end{code} @@@ -624,30 -592,3 +606,29 @@@ mkPArrFakeCon arity = data_co 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} diff --cc compiler/typecheck/TcHsType.lhs index 669c61c,65f16c5..2174be3 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@@ -366,14 -364,6 +365,11 @@@ kc_hs_type (HsPArrTy ty) = d 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) diff --cc compiler/types/Kind.lhs index 0000000,0594f7f..32a9eac mode 000000,100644..100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@@ -1,0 -1,235 +1,238 @@@ + % + % (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}