Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc.git] / compiler / types / Kind.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
6 module Kind (
7         -- * Main data type
8         Kind, typeKind,
9
10         -- Kinds
11         liftedTypeKind, unliftedTypeKind, openTypeKind,
12         argTypeKind, ubxTupleKind, constraintKind,
13         mkArrowKind, mkArrowKinds,
14
15         -- Kind constructors...
16         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
17         argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
18
19         -- Super Kinds
20         tySuperKind, tySuperKindTyCon, 
21         
22         pprKind, pprParendKind,
23
24         -- ** Deconstructing Kinds
25         kindFunResult, kindAppResult, synTyConResKind,
26         splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
27
28         -- ** Predicates on Kinds
29         isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
30         isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, isTySuperKind,
31         isSuperKind, 
32         isLiftedTypeKindCon, isConstraintKindCon,
33
34         isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
35         isSubKindCon,
36
37        ) where
38
39 #include "HsVersions.h"
40
41 import {-# SOURCE #-} Type (typeKind)
42
43 import TypeRep
44 import TysPrim
45 import TyCon
46 import PrelNames
47 import Outputable
48 \end{code}
49
50 %************************************************************************
51 %*                                                                      *
52         Predicates over Kinds
53 %*                                                                      *
54 %************************************************************************
55
56 \begin{code}
57 isTySuperKind :: SuperKind -> Bool
58 isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
59 isTySuperKind _                = False
60
61 -------------------
62 -- Lastly we need a few functions on Kinds
63
64 isLiftedTypeKindCon :: TyCon -> Bool
65 isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
66 \end{code}
67
68 %************************************************************************
69 %*                                                                      *
70         Functions over Kinds            
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 -- | Essentially 'funResultTy' on kinds
76 kindFunResult :: Kind -> Kind
77 kindFunResult (FunTy _ res) = res
78 kindFunResult k = pprPanic "kindFunResult" (ppr k)
79
80 kindAppResult :: Kind -> [arg] -> Kind
81 kindAppResult k []     = k
82 kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
83
84 -- | Essentially 'splitFunTys' on kinds
85 splitKindFunTys :: Kind -> ([Kind],Kind)
86 splitKindFunTys (FunTy a r) = case splitKindFunTys r of
87                               (as, k) -> (a:as, k)
88 splitKindFunTys k = ([], k)
89
90 splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
91 splitKindFunTy_maybe (FunTy a r) = Just (a,r)
92 splitKindFunTy_maybe _           = Nothing
93
94 -- | Essentially 'splitFunTysN' on kinds
95 splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
96 splitKindFunTysN 0 k           = ([], k)
97 splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of
98                                    (as, k) -> (a:as, k)
99 splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
100
101 -- | Find the result 'Kind' of a type synonym, 
102 -- after applying it to its 'arity' number of type variables
103 -- Actually this function works fine on data types too, 
104 -- but they'd always return '*', so we never need to ask
105 synTyConResKind :: TyCon -> Kind
106 synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
107
108 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
109 isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, isConstraintKind :: Kind -> Bool
110 isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
111         isUnliftedTypeKindCon, isSubArgTypeKindCon, isConstraintKindCon      :: TyCon -> Bool
112
113 isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey
114
115 isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
116 isOpenTypeKind _               = False
117
118 isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
119
120 isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
121 isUbxTupleKind _               = False
122
123 isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
124
125 isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
126 isArgTypeKind _               = False
127
128 isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
129
130 isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
131 isUnliftedTypeKind _               = False
132
133 isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey
134
135 isConstraintKind (TyConApp tc _) = isConstraintKindCon tc
136 isConstraintKind _               = False
137
138 isSubOpenTypeKind :: Kind -> Bool
139 -- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
140 isSubOpenTypeKind (FunTy k1 k2)    = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) 
141                                      ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) 
142                                      False
143 isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
144 isSubOpenTypeKind other            = ASSERT( isKind other ) False
145          -- This is a conservative answer
146          -- It matters in the call to isSubKind in
147          -- checkExpectedKind.
148
149 isSubArgTypeKindCon kc
150   | isUnliftedTypeKindCon kc = True
151   | isLiftedTypeKindCon kc   = True
152   | isArgTypeKindCon kc      = True
153   | isConstraintKindCon kc   = True
154   | otherwise                = False
155
156 isSubArgTypeKind :: Kind -> Bool
157 -- ^ True of any sub-kind of ArgTypeKind 
158 isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
159 isSubArgTypeKind _                = False
160
161 -- | Is this a super-kind (i.e. a type-of-kinds)?
162 isSuperKind :: Type -> Bool
163 isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
164 isSuperKind _                   = False
165
166 -- | Is this a kind (i.e. a type-of-types)?
167 isKind :: Kind -> Bool
168 isKind k = isSuperKind (typeKind k)
169
170 isSubKind :: Kind -> Kind -> Bool
171 -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
172 isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
173 isSubKind (FunTy a1 r1) (FunTy a2 r2)         = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
174 isSubKind _             _                     = False
175
176 isSubKindCon :: TyCon -> TyCon -> Bool
177 -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
178 isSubKindCon kc1 kc2
179   | isLiftedTypeKindCon kc1   && isLiftedTypeKindCon kc2   = True
180   | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
181   | isUbxTupleKindCon kc1     && isUbxTupleKindCon kc2     = True
182   | isConstraintKindCon kc1   && isConstraintKindCon kc2   = True
183   | isOpenTypeKindCon kc2                                  = True 
184                            -- we already know kc1 is not a fun, its a TyCon
185   | isArgTypeKindCon kc2      && isSubArgTypeKindCon kc1   = True
186   | otherwise                                              = False
187
188 defaultKind :: Kind -> Kind
189 -- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
190 -- information on what that means
191
192 -- When we generalise, we make generic type variables whose kind is
193 -- simple (* or *->* etc).  So generic type variables (other than
194 -- built-in constants like 'error') always have simple kinds.  This is important;
195 -- consider
196 --      f x = True
197 -- We want f to get type
198 --      f :: forall (a::*). a -> Bool
199 -- Not 
200 --      f :: forall (a::??). a -> Bool
201 -- because that would allow a call like (f 3#) as well as (f True),
202 --and the calling conventions differ.  This defaulting is done in TcMType.zonkTcTyVarBndr.
203 defaultKind k 
204   | isSubOpenTypeKind k = liftedTypeKind
205   | isSubArgTypeKind k  = liftedTypeKind
206   | otherwise        = k
207 \end{code}