37aaa56039836b4cf8400c2c171d17c2c91e7cd3
[ghc.git] / compiler / hsSyn / HsTypes.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 HsTypes: Abstract syntax: user-defined types
7
8 \begin{code}
9 {-# LANGUAGE DeriveDataTypeable #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE FlexibleInstances #-}
12 {-# LANGUAGE StandaloneDeriving #-}
13 {-# LANGUAGE TypeSynonymInstances #-}
14 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
15                                       -- in module PlaceHolder
16 {-# LANGUAGE ConstraintKinds #-}
17
18 module HsTypes (
19         HsType(..), LHsType, HsKind, LHsKind,
20         HsTyOp,LHsTyOp,
21         HsTyVarBndr(..), LHsTyVarBndr, 
22         LHsTyVarBndrs(..),
23         HsWithBndrs(..),
24         HsTupleSort(..), HsExplicitFlag(..),
25         HsContext, LHsContext,
26         HsQuasiQuote(..),
27         HsTyWrapper(..),
28         HsTyLit(..),
29         HsIPName(..), hsIPNameFS,
30
31         LBangType, BangType, HsBang(..), 
32         getBangType, getBangStrictness, 
33
34         ConDeclField(..), LConDeclField, pprConDeclFields,
35         
36         mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
37         mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
38         hsExplicitTvs,
39         hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
40         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
41         splitLHsInstDeclTy_maybe,
42         splitHsClassTy_maybe, splitLHsClassTy_maybe,
43         splitHsFunType,
44         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
45         isWildcardTy, isNamedWildcardTy,
46
47         -- Printing
48         pprParendHsType, pprHsForAll, pprHsForAllExtra,
49         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
50     ) where
51
52 import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
53
54 import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
55
56 import Name( Name )
57 import RdrName( RdrName )
58 import DataCon( HsBang(..) )
59 import TysPrim( funTyConName )
60 import Type
61 import HsDoc
62 import BasicTypes
63 import SrcLoc
64 import StaticFlags
65 import Outputable
66 import FastString
67 import Maybes( isJust )
68
69 import Data.Data hiding ( Fixity )
70 import Data.Maybe ( fromMaybe )
71 \end{code}
72
73
74 %************************************************************************
75 %*                                                                      *
76         Quasi quotes; used in types and elsewhere
77 %*                                                                      *
78 %************************************************************************
79
80 \begin{code}
81 data HsQuasiQuote id = HsQuasiQuote 
82                            id           -- The quasi-quoter
83                            SrcSpan      -- The span of the enclosed string
84                            FastString   -- The enclosed string
85   deriving (Data, Typeable)
86
87 instance OutputableBndr id => Outputable (HsQuasiQuote id) where
88     ppr = ppr_qq
89
90 ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
91 ppr_qq (HsQuasiQuote quoter _ quote) =
92     char '[' <> ppr quoter <> ptext (sLit "|") <>
93     ppr quote <> ptext (sLit "|]")
94 \end{code}
95
96
97 %************************************************************************
98 %*                                                                      *
99 \subsection{Bang annotations}
100 %*                                                                      *
101 %************************************************************************
102
103 \begin{code}
104 type LBangType name = Located (BangType name)
105 type BangType name  = HsType name       -- Bangs are in the HsType data type
106
107 getBangType :: LHsType a -> LHsType a
108 getBangType (L _ (HsBangTy _ ty)) = ty
109 getBangType ty                    = ty
110
111 getBangStrictness :: LHsType a -> HsBang
112 getBangStrictness (L _ (HsBangTy s _)) = s
113 getBangStrictness _                    = HsNoBang
114 \end{code}
115
116
117 %************************************************************************
118 %*                                                                      *
119 \subsection{Data types}
120 %*                                                                      *
121 %************************************************************************
122
123 This is the syntax for types as seen in type signatures.
124
125 Note [HsBSig binder lists]
126 ~~~~~~~~~~~~~~~~~~~~~~~~~~
127 Consider a binder (or pattern) decoarated with a type or kind, 
128    \ (x :: a -> a). blah
129    forall (a :: k -> *) (b :: k). blah
130 Then we use a LHsBndrSig on the binder, so that the
131 renamer can decorate it with the variables bound
132 by the pattern ('a' in the first example, 'k' in the second),
133 assuming that neither of them is in scope already
134 See also Note [Kind and type-variable binders] in RnTypes
135
136 \begin{code}
137 type LHsContext name = Located (HsContext name)
138
139 type HsContext name = [LHsType name]
140
141 type LHsType name = Located (HsType name)
142       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
143       --   in a list
144 type HsKind name = HsType name
145 type LHsKind name = Located (HsKind name)
146
147 type LHsTyVarBndr name = Located (HsTyVarBndr name)
148
149 data LHsTyVarBndrs name
150   = HsQTvs { hsq_kvs :: [Name]                  -- Kind variables
151            , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
152              -- See Note [HsForAllTy tyvar binders]
153     }
154   deriving( Typeable )
155 deriving instance (DataId name) => Data (LHsTyVarBndrs name)
156
157 mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
158 -- Just at RdrName because in the Name variant we should know just
159 -- what the kind-variable binders are; and we don't
160 -- We put an empty list (rather than a panic) for the kind vars so
161 -- that the pretty printer works ok on them.
162 mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
163
164 emptyHsQTvs :: LHsTyVarBndrs name   -- Use only when you know there are no kind binders
165 emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
166
167 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
168 hsQTvBndrs = hsq_tvs
169
170 data HsWithBndrs name thing
171   = HsWB { hswb_cts :: thing             -- Main payload (type or list of types)
172          , hswb_kvs :: PostRn name [Name] -- Kind vars
173          , hswb_tvs :: PostRn name [Name] -- Type vars
174          , hswb_wcs :: PostRn name [Name] -- Wildcards
175     }
176   deriving (Typeable)
177 deriving instance (Data name, Data thing, Data (PostRn name [Name]))
178   => Data (HsWithBndrs name thing)
179
180 mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing
181 mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder
182                                      , hswb_tvs = PlaceHolder
183                                      , hswb_wcs = PlaceHolder }
184
185
186 -- | These names are used early on to store the names of implicit
187 -- parameters.  They completely disappear after type-checking.
188 newtype HsIPName = HsIPName FastString-- ?x
189   deriving( Eq, Data, Typeable )
190
191 hsIPNameFS :: HsIPName -> FastString
192 hsIPNameFS (HsIPName n) = n
193
194 instance Outputable HsIPName where
195     ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters
196
197 instance OutputableBndr HsIPName where
198     pprBndr _ n   = ppr n         -- Simple for now
199     pprInfixOcc  n = ppr n
200     pprPrefixOcc n = ppr n
201
202 data HsTyVarBndr name
203   = UserTyVar        -- no explicit kinding
204          name
205
206   | KindedTyVar
207          name
208          (LHsKind name)  -- The user-supplied kind signature
209         -- ^
210         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
211         --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
212   deriving (Typeable)
213 deriving instance (DataId name) => Data (HsTyVarBndr name)
214
215 -- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
216 isHsKindedTyVar :: HsTyVarBndr name -> Bool
217 isHsKindedTyVar (UserTyVar {})   = False
218 isHsKindedTyVar (KindedTyVar {}) = True
219
220 -- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations?
221 hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
222 hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
223
224 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
225 --            'ApiAnnotation.AnnTilde','ApiAnnotation.AnnRarrow',
226 --            'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
227 --            'ApiAnnotation.AnnComma'
228 data HsType name
229   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
230                                         -- the user wrote it originally, so that the printer can
231                                         -- print it as the user wrote it
232                 (Maybe SrcSpan)         -- Indicates whether extra constraints may be inferred.
233                                         -- When Nothing, no, otherwise the location of the extra-
234                                         -- constraints wildcard is stored. For instance, for the
235                                         -- signature (Eq a, _) => a -> a -> Bool, this field would
236                                         -- be something like (Just 1:8), with 1:8 being line 1,
237                                         -- column 8.
238                 (LHsTyVarBndrs name)
239                 (LHsContext name)
240                 (LHsType name)
241       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
242       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
243   | HsTyVar             name            -- Type variable, type constructor, or data constructor
244                                         -- see Note [Promotions (HsTyVar)]
245
246   | HsAppTy             (LHsType name)
247                         (LHsType name)
248
249   | HsFunTy             (LHsType name)   -- function type
250                         (LHsType name)
251       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
252
253   | HsListTy            (LHsType name)  -- Element type
254
255   | HsPArrTy            (LHsType name)  -- Elem. type of parallel array: [:t:]
256
257   | HsTupleTy           HsTupleSort
258                         [LHsType name]  -- Element types (length gives arity)
259
260   | HsOpTy              (LHsType name) (LHsTyOp name) (LHsType name)
261
262   | HsParTy             (LHsType name)   -- See Note [Parens in HsSyn] in HsExpr
263         -- Parenthesis preserved for the precedence re-arrangement in RnTypes
264         -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
265
266   | HsIParamTy          HsIPName         -- (?x :: ty)
267                         (LHsType name)   -- Implicit parameters as they occur in contexts
268
269   | HsEqTy              (LHsType name)   -- ty1 ~ ty2
270                         (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
271
272   | HsKindSig           (LHsType name)  -- (ty :: kind)
273                         (LHsKind name)  -- A type with a kind signature
274
275   | HsQuasiQuoteTy      (HsQuasiQuote name)
276
277   | HsSpliceTy          (HsSplice name) 
278                         (PostTc name Kind)
279
280   | HsDocTy             (LHsType name) LHsDocString -- A documented type
281
282   | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations 
283   | HsRecTy     [LConDeclField name]    -- Only in data type declarations
284
285   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed* 
286                         -- Core Type through HsSyn.  
287
288   | HsExplicitListTy       -- A promoted explicit list
289         (PostTc name Kind) -- See Note [Promoted lists and tuples]
290         [LHsType name]
291
292   | HsExplicitTupleTy      -- A promoted explicit tuple
293         [PostTc name Kind] -- See Note [Promoted lists and tuples]
294         [LHsType name]
295
296   | HsTyLit HsTyLit      -- A promoted numeric literal.
297
298   | HsWrapTy HsTyWrapper (HsType name)  -- only in typechecker output
299
300   | HsWildcardTy           -- A type wildcard
301
302   | HsNamedWildcardTy name -- A named wildcard
303   deriving (Typeable)
304 deriving instance (DataId name) => Data (HsType name)
305
306
307 data HsTyLit
308   = HsNumTy Integer
309   | HsStrTy FastString
310     deriving (Data, Typeable)
311
312 data HsTyWrapper
313   = WpKiApps [Kind]  -- kind instantiation: [] k1 k2 .. kn
314   deriving (Data, Typeable)
315
316 type LHsTyOp name = HsTyOp (Located name)
317 type HsTyOp name = (HsTyWrapper, name)
318
319 mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
320 mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
321 \end{code}
322
323 Note [HsForAllTy tyvar binders]
324 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
325 After parsing:
326   * Implicit => empty
327     Explicit => the variables the user wrote
328
329 After renaming
330   * Implicit => the *type* variables free in the type
331     Explicit => the variables the user wrote (renamed)
332
333 Qualified currently behaves exactly as Implicit,
334 but it is deprecated to use it for implicit quantification.
335 In this case, GHC 7.10 gives a warning; see
336 Note [Context quantification] and Trac #4426.
337 In GHC 7.12, Qualified will no longer bind variables
338 and this will become an error.
339
340 The kind variables bound in the hsq_kvs field come both
341   a) from the kind signatures on the kind vars (eg k1)
342   b) from the scope of the forall (eg k2)
343 Example:   f :: forall (a::k1) b. T a (b::k2)
344
345
346 Note [Unit tuples]
347 ~~~~~~~~~~~~~~~~~~
348 Consider the type
349     type instance F Int = ()
350 We want to parse that "()" 
351     as HsTupleTy HsBoxedOrConstraintTuple [], 
352 NOT as HsTyVar unitTyCon
353
354 Why? Because F might have kind (* -> Constraint), so we when parsing we
355 don't know if that tuple is going to be a constraint tuple or an ordinary
356 unit tuple.  The HsTupleSort flag is specifically designed to deal with
357 that, but it has to work for unit tuples too.
358
359 Note [Promotions (HsTyVar)]
360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
361 HsTyVar: A name in a type or kind.
362   Here are the allowed namespaces for the name.
363     In a type:
364       Var: not allowed
365       Data: promoted data constructor
366       Tv: type variable
367       TcCls before renamer: type constructor, class constructor, or promoted data constructor
368       TcCls after renamer: type constructor or class constructor
369     In a kind:
370       Var, Data: not allowed
371       Tv: kind variable
372       TcCls: kind constructor or promoted type constructor
373
374
375 Note [Promoted lists and tuples]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 Notice the difference between
378    HsListTy    HsExplicitListTy
379    HsTupleTy   HsExplicitListTupleTy
380
381 E.g.    f :: [Int]                      HsListTy                
382
383         g3  :: T '[]                   All these use  
384         g2  :: T '[True]                  HsExplicitListTy        
385         g1  :: T '[True,False]          
386         g1a :: T [True,False]             (can omit ' where unambiguous)
387
388   kind of T :: [Bool] -> *        This kind uses HsListTy!
389
390 E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair               
391         k :: S '(True,False)            HsExplicitTypleTy; S is indexed by   
392                                            a type-level pair of booleans 
393         kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy
394
395 Note [Distinguishing tuple kinds]
396 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
397
398 Apart from promotion, tuples can have one of three different kinds:
399
400         x :: (Int, Bool)                -- Regular boxed tuples
401         f :: Int# -> (# Int#, Int# #)   -- Unboxed tuples
402         g :: (Eq a, Ord a) => a         -- Constraint tuples
403
404 For convenience, internally we use a single constructor for all of these,
405 namely HsTupleTy, but keep track of the tuple kind (in the first argument to
406 HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,
407 because of the #. However, with -XConstraintKinds we can only distinguish
408 between constraint and boxed tuples during type checking, in general. Hence the
409 four constructors of HsTupleSort:
410         
411         HsUnboxedTuple                  -> Produced by the parser
412         HsBoxedTuple                    -> Certainly a boxed tuple
413         HsConstraintTuple               -> Certainly a constraint tuple
414         HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint 
415                                         tuple. Produced by the parser only,
416                                         disappears after type checking
417
418 \begin{code}
419 data HsTupleSort = HsUnboxedTuple
420                  | HsBoxedTuple
421                  | HsConstraintTuple
422                  | HsBoxedOrConstraintTuple
423                  deriving (Data, Typeable)
424
425 data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
426
427 type LConDeclField name = Located (ConDeclField name)
428       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
429       --   in a list
430 data ConDeclField name  -- Record fields have Haddoc docs on them
431   = ConDeclField { cd_fld_names :: [Located name],
432                    cd_fld_type  :: LBangType name,
433                    cd_fld_doc   :: Maybe LHsDocString }
434       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
435   deriving (Typeable)
436 deriving instance (DataId name) => Data (ConDeclField name)
437
438 -----------------------
439 -- Combine adjacent for-alls. 
440 -- The following awkward situation can happen otherwise:
441 --      f :: forall a. ((Num a) => Int)
442 -- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
443 -- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
444 -- but the export list abstracts f wrt [a].  Disaster.
445 --
446 -- A valid type must have one for-all at the top of the type, or of the fn arg types
447
448 mkImplicitHsForAllTy  ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
449 mkExplicitHsForAllTy  :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
450 mkQualifiedHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
451 mkImplicitHsForAllTy      ctxt ty = mkHsForAllTy Implicit  []  ctxt ty
452 mkExplicitHsForAllTy  tvs ctxt ty = mkHsForAllTy Explicit  tvs ctxt ty
453 mkQualifiedHsForAllTy     ctxt ty = mkHsForAllTy Qualified []  ctxt ty
454
455 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
456 -- Smart constructor for HsForAllTy
457 mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
458 mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt ty
459   where -- Separate the extra-constraints wildcard when present
460         (cleanCtxt, extra)
461           | (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l)
462           | otherwise = (ctxt, Nothing)
463         ignoreParens (L _ (HsParTy ty)) = ty
464         ignoreParens ty                 = ty
465
466
467 -- mk_forall_ty makes a pure for-all type (no context)
468 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
469 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
470   = addExtra $ mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
471   where addExtra (HsForAllTy exp _ qtvs ctxt ty) = HsForAllTy exp extra qtvs ctxt ty
472         addExtra ty = ty -- Impossible, as mkHsForAllTy always returns a HsForAllTy
473 mk_forall_ty exp  tvs  (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty
474 mk_forall_ty exp  tvs  ty                 = HsForAllTy exp Nothing (mkHsQTvs tvs) (noLoc []) ty
475         -- Even if tvs is empty, we still make a HsForAll!
476         -- In the Implicit case, this signals the place to do implicit quantification
477         -- In the Explicit case, it prevents implicit quantification    
478         --      (see the sigtype production in Parser.y)
479         --      so that (forall. ty) isn't implicitly quantified
480
481 plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
482 Qualified `plus` Qualified = Qualified
483 Explicit  `plus` _         = Explicit
484 _         `plus` Explicit  = Explicit
485 _         `plus` _         = Implicit
486
487 hsExplicitTvs :: LHsType Name -> [Name]
488 -- The explicitly-given forall'd type variables of a HsType
489 hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
490 hsExplicitTvs _                                     = []
491
492 ---------------------
493 hsTyVarName :: HsTyVarBndr name -> name
494 hsTyVarName (UserTyVar n)     = n
495 hsTyVarName (KindedTyVar n _) = n
496
497 hsLTyVarName :: LHsTyVarBndr name -> name
498 hsLTyVarName = hsTyVarName . unLoc
499
500 hsLTyVarNames :: LHsTyVarBndrs name -> [name]
501 -- Type variables only
502 hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
503
504 hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name]
505 -- Kind and type variables
506 hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
507   = kvs ++ map hsLTyVarName tvs
508
509 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
510 hsLTyVarLocName = fmap hsTyVarName
511
512 hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
513 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
514
515 ---------------------
516 isWildcardTy :: HsType a -> Bool
517 isWildcardTy HsWildcardTy = True
518 isWildcardTy _ = False
519
520 isNamedWildcardTy :: HsType a -> Bool
521 isNamedWildcardTy (HsNamedWildcardTy _) = True
522 isNamedWildcardTy _ = False
523 \end{code}
524
525
526 \begin{code}
527 splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
528 splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
529 splitHsAppTys (L _ (HsParTy f))   as = splitHsAppTys f as
530 splitHsAppTys f                   as = (f,as)
531
532 -- retrieve the name of the "head" of a nested type application
533 -- somewhat like splitHsAppTys, but a little more thorough
534 -- used to examine the result of a GADT-like datacon, so it doesn't handle
535 -- *all* cases (like lists, tuples, (~), etc.)
536 hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n])
537 hsTyGetAppHead_maybe = go []
538   where
539     go tys (L _ (HsTyVar n))             = Just (n, tys)
540     go tys (L _ (HsAppTy l r))           = go (r : tys) l
541     go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys)
542     go tys (L _ (HsParTy t))             = go tys t
543     go tys (L _ (HsKindSig t _))         = go tys t
544     go _   _                             = Nothing
545
546 mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
547 mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
548 mkHsAppTys fun_ty (arg_ty:arg_tys)
549   = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
550   where
551     mk_app fun arg = HsAppTy (noLoc fun) arg    
552        -- Add noLocs for inner nodes of the application; 
553        -- they are never used 
554
555 splitLHsInstDeclTy_maybe
556     :: LHsType name 
557     -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
558         -- Split up an instance decl type, returning the pieces
559 splitLHsInstDeclTy_maybe inst_ty = do
560     let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
561     (cls, tys) <- splitLHsClassTy_maybe ty
562     return (tvs, cxt, cls, tys)
563
564 splitLHsForAllTy
565     :: LHsType name 
566     -> (LHsTyVarBndrs name, HsContext name, LHsType name)
567 splitLHsForAllTy poly_ty
568   = case unLoc poly_ty of
569         HsParTy ty                -> splitLHsForAllTy ty
570         HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty)
571         _                         -> (emptyHsQTvs, [], poly_ty)
572         -- The type vars should have been computed by now, even if they were implicit
573
574 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
575 splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
576
577 splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
578 --- Watch out.. in ...deriving( Show )... we use this on 
579 --- the list of partially applied predicates in the deriving,
580 --- so there can be zero args.
581
582 -- In TcDeriv we also use this to figure out what data type is being
583 -- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo").
584 splitLHsClassTy_maybe ty
585   = checkl ty []
586   where
587     checkl (L l ty) args = case ty of
588         HsTyVar t          -> Just (L l t, args)
589         HsAppTy l r        -> checkl l (r:args)
590         HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args)
591         HsParTy t          -> checkl t args
592         HsKindSig ty _     -> checkl ty args
593         _                  -> Nothing
594
595 -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
596 -- Breaks up any parens in the result type: 
597 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
598 -- Also deals with (->) t1 t2; that is why it only works on LHsType Name
599 --   (see Trac #9096)
600 splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
601 splitHsFunType (L _ (HsParTy ty)) 
602   = splitHsFunType ty
603
604 splitHsFunType (L _ (HsFunTy x y))
605   | (args, res) <- splitHsFunType y
606   = (x:args, res)
607
608 splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) 
609   = go t1 [t2]
610   where  -- Look for (->) t1 t2, possibly with parenthesisation
611     go (L _ (HsTyVar fn))    tys | fn == funTyConName
612                                  , [t1,t2] <- tys
613                                  , (args, res) <- splitHsFunType t2
614                                  = (t1:args, res)
615     go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
616     go (L _ (HsParTy ty))    tys = go ty tys
617     go _                     _   = ([], orig_ty)  -- Failure to match
618
619 splitHsFunType other = ([], other)
620 \end{code}
621
622
623 %************************************************************************
624 %*                                                                      *
625 \subsection{Pretty printing}
626 %*                                                                      *
627 %************************************************************************
628
629 \begin{code}
630 instance (OutputableBndr name) => Outputable (HsType name) where
631     ppr ty = pprHsType ty
632
633 instance Outputable HsTyLit where
634     ppr = ppr_tylit
635
636 instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
637     ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) 
638       = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
639
640 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
641     ppr (UserTyVar n)     = ppr n
642     ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
643
644 instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
645     ppr (HsWB { hswb_cts = ty }) = ppr ty
646
647 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
648 pprHsForAll exp = pprHsForAllExtra exp Nothing
649
650 -- | Version of 'pprHsForAll' that can also print an extra-constraints
651 -- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This
652 -- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just'
653 -- containing the location of the extra-constraints wildcard. A special
654 -- function for this is needed, as the extra-constraints wildcard is removed
655 -- from the actual context and type, and stored in a separate field, thus just
656 -- printing the type will not print the extra-constraints wildcard.
657 pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc
658 pprHsForAllExtra exp extra qtvs cxt
659   | show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt)
660   | otherwise   = pprHsContextExtra show_extra (unLoc cxt)
661   where
662     show_extra  = isJust extra
663     show_forall =  opt_PprStyle_Debug
664                 || (not (null (hsQTvBndrs qtvs)) && is_explicit)
665     is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False}
666     forall_part = forAllLit <+> ppr qtvs <> dot
667
668 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
669 pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
670
671 pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc
672 pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
673
674 pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc
675 pprHsContextMaybe []         = Nothing
676 pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
677 pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
678
679 -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
680 pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc
681 pprHsContextExtra False = pprHsContext
682 pprHsContextExtra True
683   = \ctxt -> case ctxt of
684                [] -> char '_' <+> darrow
685                _  -> parens (sep (punctuate comma ctxt')) <+> darrow
686                  where ctxt' = map ppr ctxt ++ [char '_']
687
688 pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
689 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
690   where
691     ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
692                                  cd_fld_doc = doc }))
693         = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
694     ppr_names [n] = ppr n
695     ppr_names ns = sep (punctuate comma (map ppr ns))
696 \end{code}
697
698 Note [Printing KindedTyVars]
699 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
700 Trac #3830 reminded me that we should really only print the kind
701 signature on a KindedTyVar if the kind signature was put there by the
702 programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,
703 rather than converting to KindedTyVars as before.
704
705 (As it happens, the message in #3830 comes out a different way now,
706 and the problem doesn't show up; but having the flag on a KindedTyVar
707 seems like the Right Thing anyway.)
708
709 \begin{code}
710 -- Printing works more-or-less as for Types
711
712 pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
713
714 pprHsType ty       = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty)
715 pprParendHsType ty = ppr_mono_ty TyConPrec ty
716
717 -- Before printing a type
718 -- (a) Remove outermost HsParTy parens
719 -- (b) Drop top-level for-all type variables in user style
720 --     since they are implicit in Haskell
721 prepare :: PprStyle -> HsType name -> HsType name
722 prepare sty (HsParTy ty)          = prepare sty (unLoc ty)
723 prepare _   ty                    = ty
724
725 ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
726 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
727
728 ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
729 ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty)
730   = maybeParen ctxt_prec FunPrec $
731     sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty]
732
733 ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty TyConPrec ty
734 ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
735 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
736 ppr_mono_ty _    (HsTyVar name)      = pprPrefixOcc name
737 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
738 ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
739   where std_con = case con of
740                     HsUnboxedTuple -> UnboxedTuple
741                     _              -> BoxedTuple
742 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind)
743 ppr_mono_ty _    (HsListTy ty)       = brackets (ppr_mono_lty TopPrec ty)
744 ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty TopPrec ty)
745 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
746 ppr_mono_ty _    (HsSpliceTy s _)    = pprUntypedSplice s
747 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
748 ppr_mono_ty _    (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
749 ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
750 ppr_mono_ty _    (HsTyLit t)         = ppr_tylit t
751 ppr_mono_ty _    HsWildcardTy        = char '_'
752 ppr_mono_ty _    (HsNamedWildcardTy name) = ppr name
753
754 ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
755   = ppr_mono_ty ctxt_prec ty
756 -- We are not printing kind applications. If we wanted to do so, we should do
757 -- something like this:
758 {-
759   = go ctxt_prec kis ty
760   where
761     go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty
762     go ctxt_prec (ki:kis) ty
763       = maybeParen ctxt_prec TyConPrec $
764         hsep [ go FunPrec kis ty
765              , ptext (sLit "@") <> pprParendKind ki ]
766 -}
767
768 ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
769   = maybeParen ctxt_prec TyOpPrec $
770     ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
771
772 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
773   = maybeParen ctxt_prec TyConPrec $
774     hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
775
776 ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2)
777   = maybeParen ctxt_prec TyOpPrec $
778     sep [ ppr_mono_lty TyOpPrec ty1
779         , sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]
780     -- Don't print the wrapper (= kind applications)
781     -- c.f. HsWrapTy
782
783 ppr_mono_ty _         (HsParTy ty)
784   = parens (ppr_mono_lty TopPrec ty)
785   -- Put the parens in where the user did
786   -- But we still use the precedence stuff to add parens because
787   --    toHsType doesn't put in any HsParTys, so we may still need them
788
789 ppr_mono_ty ctxt_prec (HsDocTy ty doc) 
790   = maybeParen ctxt_prec TyOpPrec $
791     ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc)
792   -- we pretty print Haddock comments on types as if they were
793   -- postfix operators
794
795 --------------------------
796 ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc
797 ppr_fun_ty ctxt_prec ty1 ty2
798   = let p1 = ppr_mono_lty FunPrec ty1
799         p2 = ppr_mono_lty TopPrec ty2
800     in
801     maybeParen ctxt_prec FunPrec $
802     sep [p1, ptext (sLit "->") <+> p2]
803
804 --------------------------
805 ppr_tylit :: HsTyLit -> SDoc
806 ppr_tylit (HsNumTy i) = integer i
807 ppr_tylit (HsStrTy s) = text (show s)
808 \end{code}
809
810