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