Fix scoping for RHS of associated type decls (fixes Trac #5515)
[ghc.git] / compiler / hsSyn / HsDecls.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 {-# LANGUAGE DeriveDataTypeable #-}
8
9 -- | Abstract syntax of global declarations.
10 --
11 -- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
12 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
13 module HsDecls (
14   -- * Toplevel declarations
15   HsDecl(..), LHsDecl,
16   -- ** Class or type declarations
17   TyClDecl(..), LTyClDecl,
18   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
19   isFamInstDecl, tcdName, tyClDeclTyVars,
20   countTyClDecls,
21   -- ** Instance declarations
22   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
23   instDeclATs,
24   -- ** Standalone deriving declarations
25   DerivDecl(..), LDerivDecl,
26   -- ** @RULE@ declarations
27   RuleDecl(..), LRuleDecl, RuleBndr(..),
28   collectRuleBndrSigTys,
29   -- ** @VECTORISE@ declarations
30   VectDecl(..), LVectDecl,
31   lvectDeclName,
32   -- ** @default@ declarations
33   DefaultDecl(..), LDefaultDecl,
34   -- ** Top-level template haskell splice
35   SpliceDecl(..),
36   -- ** Foreign function interface declarations
37   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
38   CImportSpec(..),
39   -- ** Data-constructor declarations
40   ConDecl(..), LConDecl, ResType(..), 
41   HsConDeclDetails, hsConDeclArgTys, 
42   -- ** Document comments
43   DocDecl(..), LDocDecl, docDeclDoc,
44   -- ** Deprecations
45   WarnDecl(..),  LWarnDecl,
46   -- ** Annotations
47   AnnDecl(..), LAnnDecl, 
48   AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
49
50   -- * Grouping
51   HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
52     ) where
53
54 -- friends:
55 import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, pprExpr )
56         -- Because Expr imports Decls via HsBracket
57
58 import HsBinds
59 import HsPat
60 import HsTypes
61 import HsDoc
62 import TyCon
63 import NameSet
64 import Name
65 import {- Kind parts of -} Type
66 import BasicTypes
67 import ForeignCall
68
69 -- others:
70 import Class
71 import Outputable       
72 import Util
73 import SrcLoc
74 import FastString
75
76 import Bag
77 import Control.Monad    ( liftM )
78 import Data.Data        hiding (TyCon)
79 import Data.Maybe       ( isJust )
80 \end{code}
81
82 %************************************************************************
83 %*                                                                      *
84 \subsection[HsDecl]{Declarations}
85 %*                                                                      *
86 %************************************************************************
87
88 \begin{code}
89 type LHsDecl id = Located (HsDecl id)
90
91 -- | A Haskell Declaration
92 data HsDecl id
93   = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
94   | InstD       (InstDecl  id)    -- ^ An instance declaration.
95   | DerivD      (DerivDecl id)
96   | ValD        (HsBind id)
97   | SigD        (Sig id)
98   | DefD        (DefaultDecl id)
99   | ForD        (ForeignDecl id)
100   | WarningD    (WarnDecl id)
101   | AnnD        (AnnDecl id)
102   | RuleD       (RuleDecl id)
103   | VectD       (VectDecl id)
104   | SpliceD     (SpliceDecl id)
105   | DocD        (DocDecl)
106   | QuasiQuoteD (HsQuasiQuote id)
107   deriving (Data, Typeable)
108
109
110 -- NB: all top-level fixity decls are contained EITHER
111 -- EITHER SigDs
112 -- OR     in the ClassDecls in TyClDs
113 --
114 -- The former covers
115 --      a) data constructors
116 --      b) class methods (but they can be also done in the
117 --              signatures of class decls)
118 --      c) imported functions (that have an IfacSig)
119 --      d) top level decls
120 --
121 -- The latter is for class methods only
122
123 -- | A 'HsDecl' is categorised into a 'HsGroup' before being
124 -- fed to the renamer.
125 data HsGroup id
126   = HsGroup {
127         hs_valds  :: HsValBinds id,
128
129         hs_tyclds :: [[LTyClDecl id]],  
130                 -- A list of mutually-recursive groups
131                 -- Parser generates a singleton list;
132                 -- renamer does dependency analysis
133
134         hs_instds :: [LInstDecl id],
135         hs_derivds :: [LDerivDecl id],
136
137         hs_fixds  :: [LFixitySig id],
138                 -- Snaffled out of both top-level fixity signatures,
139                 -- and those in class declarations
140
141         hs_defds  :: [LDefaultDecl id],
142         hs_fords  :: [LForeignDecl id],
143         hs_warnds :: [LWarnDecl id],
144         hs_annds  :: [LAnnDecl id],
145         hs_ruleds :: [LRuleDecl id],
146         hs_vects  :: [LVectDecl id],
147
148         hs_docs   :: [LDocDecl]
149   } deriving (Data, Typeable)
150
151 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
152 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
153 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
154
155 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
156                        hs_fixds = [], hs_defds = [], hs_annds = [],
157                        hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
158                        hs_valds = error "emptyGroup hs_valds: Can't happen",
159                        hs_docs = [] }
160
161 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
162 appendGroups 
163     HsGroup { 
164         hs_valds  = val_groups1,
165         hs_tyclds = tyclds1, 
166         hs_instds = instds1,
167         hs_derivds = derivds1,
168         hs_fixds  = fixds1, 
169         hs_defds  = defds1,
170         hs_annds  = annds1,
171         hs_fords  = fords1, 
172         hs_warnds = warnds1,
173         hs_ruleds = rulds1,
174         hs_vects = vects1,
175   hs_docs   = docs1 }
176     HsGroup { 
177         hs_valds  = val_groups2,
178         hs_tyclds = tyclds2, 
179         hs_instds = instds2,
180         hs_derivds = derivds2,
181         hs_fixds  = fixds2, 
182         hs_defds  = defds2,
183         hs_annds  = annds2,
184         hs_fords  = fords2, 
185         hs_warnds = warnds2,
186         hs_ruleds = rulds2,
187         hs_vects  = vects2,
188         hs_docs   = docs2 }
189   = 
190     HsGroup { 
191         hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
192         hs_tyclds = tyclds1 ++ tyclds2, 
193         hs_instds = instds1 ++ instds2,
194         hs_derivds = derivds1 ++ derivds2,
195         hs_fixds  = fixds1 ++ fixds2,
196         hs_annds  = annds1 ++ annds2,
197         hs_defds  = defds1 ++ defds2,
198         hs_fords  = fords1 ++ fords2, 
199         hs_warnds = warnds1 ++ warnds2,
200         hs_ruleds = rulds1 ++ rulds2,
201         hs_vects  = vects1 ++ vects2,
202         hs_docs   = docs1  ++ docs2 }
203 \end{code}
204
205 \begin{code}
206 instance OutputableBndr name => Outputable (HsDecl name) where
207     ppr (TyClD dcl)             = ppr dcl
208     ppr (ValD binds)            = ppr binds
209     ppr (DefD def)              = ppr def
210     ppr (InstD inst)            = ppr inst
211     ppr (DerivD deriv)          = ppr deriv
212     ppr (ForD fd)               = ppr fd
213     ppr (SigD sd)               = ppr sd
214     ppr (RuleD rd)              = ppr rd
215     ppr (VectD vect)            = ppr vect
216     ppr (WarningD wd)           = ppr wd
217     ppr (AnnD ad)               = ppr ad
218     ppr (SpliceD dd)            = ppr dd
219     ppr (DocD doc)              = ppr doc
220     ppr (QuasiQuoteD qq)        = ppr qq
221
222 instance OutputableBndr name => Outputable (HsGroup name) where
223     ppr (HsGroup { hs_valds  = val_decls,
224                    hs_tyclds = tycl_decls,
225                    hs_instds = inst_decls,
226                    hs_derivds = deriv_decls,
227                    hs_fixds  = fix_decls,
228                    hs_warnds = deprec_decls,
229                    hs_annds  = ann_decls,
230                    hs_fords  = foreign_decls,
231                    hs_defds  = default_decls,
232                    hs_ruleds = rule_decls,
233                    hs_vects  = vect_decls })
234         = vcat_mb empty 
235             [ppr_ds fix_decls, ppr_ds default_decls, 
236              ppr_ds deprec_decls, ppr_ds ann_decls,
237              ppr_ds rule_decls,
238              ppr_ds vect_decls,
239              if isEmptyValBinds val_decls 
240                 then Nothing 
241                 else Just (ppr val_decls),
242              ppr_ds (concat tycl_decls), 
243              ppr_ds inst_decls,
244              ppr_ds deriv_decls,
245              ppr_ds foreign_decls]
246         where
247           ppr_ds :: Outputable a => [a] -> Maybe SDoc
248           ppr_ds [] = Nothing
249           ppr_ds ds = Just (vcat (map ppr ds))
250
251           vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
252           -- Concatenate vertically with white-space between non-blanks
253           vcat_mb _    []             = empty
254           vcat_mb gap (Nothing : ds) = vcat_mb gap ds
255           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
256
257 data SpliceDecl id 
258   = SpliceDecl                  -- Top level splice
259         (Located (HsExpr id))
260         HsExplicitFlag          -- Explicit <=> $(f x y)
261                                 -- Implicit <=> f x y,  i.e. a naked top level expression
262     deriving (Data, Typeable)
263
264 instance OutputableBndr name => Outputable (SpliceDecl name) where
265    ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
266 \end{code}
267
268
269 %************************************************************************
270 %*                                                                      *
271 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
272 %*                                                                      *
273 %************************************************************************
274
275                 --------------------------------
276                         THE NAMING STORY
277                 --------------------------------
278
279 Here is the story about the implicit names that go with type, class,
280 and instance decls.  It's a bit tricky, so pay attention!
281
282 "Implicit" (or "system") binders
283 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
284   Each data type decl defines 
285         a worker name for each constructor
286         to-T and from-T convertors
287   Each class decl defines
288         a tycon for the class
289         a data constructor for that tycon
290         the worker for that constructor
291         a selector for each superclass
292
293 All have occurrence names that are derived uniquely from their parent
294 declaration.
295
296 None of these get separate definitions in an interface file; they are
297 fully defined by the data or class decl.  But they may *occur* in
298 interface files, of course.  Any such occurrence must haul in the
299 relevant type or class decl.
300
301 Plan of attack:
302  - Ensure they "point to" the parent data/class decl 
303    when loading that decl from an interface file
304    (See RnHiFiles.getSysBinders)
305
306  - When typechecking the decl, we build the implicit TyCons and Ids.
307    When doing so we look them up in the name cache (RnEnv.lookupSysName),
308    to ensure correct module and provenance is set
309
310 These are the two places that we have to conjure up the magic derived
311 names.  (The actual magic is in OccName.mkWorkerOcc, etc.)
312
313 Default methods
314 ~~~~~~~~~~~~~~~
315  - Occurrence name is derived uniquely from the method name
316    E.g. $dmmax
317
318  - If there is a default method name at all, it's recorded in
319    the ClassOpSig (in HsBinds), in the DefMeth field.
320    (DefMeth is defined in Class.lhs)
321
322 Source-code class decls and interface-code class decls are treated subtly
323 differently, which has given me a great deal of confusion over the years.
324 Here's the deal.  (We distinguish the two cases because source-code decls
325 have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.
326
327 In *source-code* class declarations:
328
329  - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
330    This is done by RdrHsSyn.mkClassOpSigDM
331
332  - The renamer renames it to a Name
333
334  - During typechecking, we generate a binding for each $dm for 
335    which there's a programmer-supplied default method:
336         class Foo a where
337           op1 :: <type>
338           op2 :: <type>
339           op1 = ...
340    We generate a binding for $dmop1 but not for $dmop2.
341    The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
342    The Name for $dmop2 is simply discarded.
343
344 In *interface-file* class declarations:
345   - When parsing, we see if there's an explicit programmer-supplied default method
346     because there's an '=' sign to indicate it:
347         class Foo a where
348           op1 = :: <type>       -- NB the '='
349           op2   :: <type>
350     We use this info to generate a DefMeth with a suitable RdrName for op1,
351     and a NoDefMeth for op2
352   - The interface file has a separate definition for $dmop1, with unfolding etc.
353   - The renamer renames it to a Name.
354   - The renamer treats $dmop1 as a free variable of the declaration, so that
355     the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)  
356     This doesn't happen for source code class decls, because they *bind* the default method.
357
358 Dictionary functions
359 ~~~~~~~~~~~~~~~~~~~~
360 Each instance declaration gives rise to one dictionary function binding.
361
362 The type checker makes up new source-code instance declarations
363 (e.g. from 'deriving' or generic default methods --- see
364 TcInstDcls.tcInstDecls1).  So we can't generate the names for
365 dictionary functions in advance (we don't know how many we need).
366
367 On the other hand for interface-file instance declarations, the decl
368 specifies the name of the dictionary function, and it has a binding elsewhere
369 in the interface file:
370         instance {Eq Int} = dEqInt
371         dEqInt :: {Eq Int} <pragma info>
372
373 So again we treat source code and interface file code slightly differently.
374
375 Source code:
376   - Source code instance decls have a Nothing in the (Maybe name) field
377     (see data InstDecl below)
378
379   - The typechecker makes up a Local name for the dict fun for any source-code
380     instance decl, whether it comes from a source-code instance decl, or whether
381     the instance decl is derived from some other construct (e.g. 'deriving').
382
383   - The occurrence name it chooses is derived from the instance decl (just for 
384     documentation really) --- e.g. dNumInt.  Two dict funs may share a common
385     occurrence name, but will have different uniques.  E.g.
386         instance Foo [Int]  where ...
387         instance Foo [Bool] where ...
388     These might both be dFooList
389
390   - The CoreTidy phase externalises the name, and ensures the occurrence name is
391     unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.
392
393   - We can take this relaxed approach (changing the occurrence name later) 
394     because dict fun Ids are not captured in a TyCon or Class (unlike default
395     methods, say).  Instead, they are kept separately in the InstEnv.  This
396     makes it easy to adjust them after compiling a module.  (Once we've finished
397     compiling that module, they don't change any more.)
398
399
400 Interface file code:
401   - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
402     in the (Maybe name) field.
403
404   - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
405     suck in the dfun binding
406
407
408 \begin{code}
409 -- Representation of indexed types
410 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
411 -- Family kind signatures are represented by the variant `TyFamily'.  It
412 -- covers "type family", "newtype family", and "data family" declarations,
413 -- distinguished by the value of the field `tcdFlavour'.
414 --
415 -- Indexed types are represented by 'TyData' and 'TySynonym' using the field
416 -- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
417 --
418 --   * If it is 'Nothing', we have a *vanilla* data type declaration or type
419 --     synonym declaration and 'tcdVars' contains the type parameters of the
420 --     type constructor.
421 --
422 --   * If it is 'Just pats', we have the definition of an indexed type.  Then,
423 --     'pats' are type patterns for the type-indexes of the type constructor
424 --     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
425 --     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
426 --     *not* 'length tcdVars'.
427 --
428 -- In both cases, 'tcdVars' collects all variables we need to quantify over.
429
430 type LTyClDecl name = Located (TyClDecl name)
431
432 -- | A type or class declaration.
433 data TyClDecl name
434   = ForeignType { 
435                 tcdLName    :: Located name,
436                 tcdExtName  :: Maybe FastString
437     }
438
439
440   | -- | @type/data family T :: *->*@
441     TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
442                 tcdLName  :: Located name,              -- type constructor
443                 tcdTyVars :: [LHsTyVarBndr name],       -- type variables
444                 tcdKind   :: Maybe Kind                 -- result kind
445     }
446
447
448   | -- | Declares a data type or newtype, giving its construcors
449     -- @
450     --  data/newtype T a = <constrs>
451     --  data/newtype instance T [a] = <constrs>
452     -- @
453     TyData {    tcdND     :: NewOrData,
454                 tcdCtxt   :: LHsContext name,           -- ^ Context
455                 tcdLName  :: Located name,              -- ^ Type constructor
456
457                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ Type variables
458                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
459                   -- See Note [tcdTyVars and tcdTyPats] 
460
461                 tcdKindSig:: Maybe Kind,
462                         -- ^ Optional kind signature.
463                         --
464                         -- @(Just k)@ for a GADT-style @data@, or @data
465                         -- instance@ decl with explicit kind sig
466
467                 tcdCons   :: [LConDecl name],
468                         -- ^ Data constructors
469                         --
470                         -- For @data T a = T1 | T2 a@
471                         --   the 'LConDecl's all have 'ResTyH98'.
472                         -- For @data T a where { T1 :: T a }@
473                         --   the 'LConDecls' all have 'ResTyGADT'.
474
475                 tcdDerivs :: Maybe [LHsType name]
476                         -- ^ Derivings; @Nothing@ => not specified,
477                         --              @Just []@ => derive exactly what is asked
478                         --
479                         -- These "types" must be of form
480                         -- @
481                         --      forall ab. C ty1 ty2
482                         -- @
483                         -- Typically the foralls and ty args are empty, but they
484                         -- are non-empty for the newtype-deriving case
485     }
486
487   | TySynonym { tcdLName  :: Located name,              -- ^ type constructor
488                 tcdTyVars :: [LHsTyVarBndr name],       -- ^ type variables
489                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
490                   -- See Note [tcdTyVars and tcdTyPats] 
491
492                 tcdSynRhs :: LHsType name               -- ^ synonym expansion
493     }
494
495   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
496                 tcdLName   :: Located name,             -- ^ Name of the class
497                 tcdTyVars  :: [LHsTyVarBndr name],      -- ^ Class type variables
498                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
499                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
500                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
501                 tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
502                                                         --   only 'TyFamily'
503                 tcdATDefs  :: [LTyClDecl name],         -- ^ Associated type defaults; ie
504                                                         --   only 'TySynonym'
505                 tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
506     }
507   deriving (Data, Typeable)
508
509 data NewOrData
510   = NewType                     -- ^ @newtype Blah ...@
511   | DataType                    -- ^ @data Blah ...@
512   deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
513
514 data FamilyFlavour
515   = TypeFamily                  -- ^ @type family ...@
516   | DataFamily                  -- ^ @data family ...@
517   deriving (Data, Typeable)
518 \end{code}
519
520 Note [tcdTyVars and tcdTyPats] 
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 We use TyData and TySynonym both for vanilla data/type declarations
523      type T a = Int
524 AND for data/type family instance declarations
525      type instance F [a] = (a,Int)
526
527 tcdTyPats = Nothing
528    This is a vanilla data type or type synonym
529    tcdTyVars are the quantified type variables
530
531 tcdTyPats = Just tys
532    This is a data/type family instance declaration
533    tcdTyVars are fv(tys)
534
535    Eg   class C a b where
536           type F a x :: *
537         instance D p s => C (p,q) [r] where
538           type F (p,q) x = p -> x
539    The tcdTyVars of the F instance decl are {p,q,x},
540    i.e. not including s, nor r 
541         (and indeed neither s nor should be mentioned
542          on the RHS of the F instance decl; Trac #5515)
543
544 ------------------------------
545 Simple classifiers
546
547 \begin{code}
548 -- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@
549 -- declaration.
550 isDataDecl :: TyClDecl name -> Bool
551 isDataDecl (TyData {}) = True
552 isDataDecl _other      = False
553
554 -- | type or type instance declaration
555 isTypeDecl :: TyClDecl name -> Bool
556 isTypeDecl (TySynonym {}) = True
557 isTypeDecl _other         = False
558
559 -- | vanilla Haskell type synonym (ie, not a type instance)
560 isSynDecl :: TyClDecl name -> Bool
561 isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
562 isSynDecl _other                            = False
563
564 -- | type class
565 isClassDecl :: TyClDecl name -> Bool
566 isClassDecl (ClassDecl {}) = True
567 isClassDecl _              = False
568
569 -- | type family declaration
570 isFamilyDecl :: TyClDecl name -> Bool
571 isFamilyDecl (TyFamily {}) = True
572 isFamilyDecl _other        = False
573
574 -- | family instance (types, newtypes, and data types)
575 isFamInstDecl :: TyClDecl name -> Bool
576 isFamInstDecl tydecl
577    | isTypeDecl tydecl
578      || isDataDecl tydecl = isJust (tcdTyPats tydecl)
579    | otherwise            = False
580 \end{code}
581
582 Dealing with names
583
584 \begin{code}
585 tcdName :: TyClDecl name -> name
586 tcdName decl = unLoc (tcdLName decl)
587
588 tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
589 tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
590 tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
591 tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
592 tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
593 tyClDeclTyVars (ForeignType {})                = []
594 \end{code}
595
596 \begin{code}
597 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
598         -- class, synonym decls, data, newtype, family decls, family instances
599 countTyClDecls decls 
600  = (count isClassDecl    decls,
601     count isSynDecl      decls,  -- excluding...
602     count isDataTy       decls,  -- ...family...
603     count isNewTy        decls,  -- ...instances
604     count isFamilyDecl   decls,
605     count isFamInstDecl  decls)
606  where
607    isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
608    isDataTy _                                             = False
609    
610    isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
611    isNewTy _                                            = False
612 \end{code}
613
614 \begin{code}
615 instance OutputableBndr name
616               => Outputable (TyClDecl name) where
617
618     ppr (ForeignType {tcdLName = ltycon})
619         = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
620
621     ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
622                    tcdTyVars = tyvars, tcdKind = mb_kind})
623       = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
624         where
625           pp_flavour = case flavour of
626                          TypeFamily -> ptext (sLit "type family")
627                          DataFamily -> ptext (sLit "data family")
628
629           pp_kind = case mb_kind of
630                       Nothing   -> empty
631                       Just kind -> dcolon <+> pprKind kind
632
633     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
634                     tcdSynRhs = mono_ty})
635       = hang (ptext (sLit "type") <+> 
636               (if isJust typats then ptext (sLit "instance") else empty) <+>
637               pp_decl_head [] ltycon tyvars typats <+> 
638               equals)
639              4 (ppr mono_ty)
640
641     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
642                  tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
643                  tcdCons = condecls, tcdDerivs = derivings})
644       = pp_tydecl (null condecls && isJust mb_sig) 
645                   (ppr new_or_data <+> 
646                    (if isJust typats then ptext (sLit "instance") else empty) <+>
647                    pp_decl_head (unLoc context) ltycon tyvars typats <+> 
648                    ppr_sigx mb_sig)
649                   (pp_condecls condecls)
650                   derivings
651       where
652         ppr_sigx Nothing     = empty
653         ppr_sigx (Just kind) = dcolon <+> pprKind kind
654
655     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
656                     tcdFDs  = fds,
657                     tcdSigs = sigs, tcdMeths = methods,
658                     tcdATs = ats, tcdATDefs = at_defs})
659       | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
660       = top_matter
661
662       | otherwise       -- Laid out
663       = vcat [ top_matter <+> ptext (sLit "where")
664              , nest 2 $ pprDeclList (map ppr ats ++
665                                      map ppr at_defs ++
666                                      pprLHsBindsForUser methods sigs) ]
667       where
668         top_matter = ptext (sLit "class") 
669                      <+> pp_decl_head (unLoc context) lclas tyvars Nothing
670                      <+> pprFundeps (map unLoc fds)
671
672 pp_decl_head :: OutputableBndr name
673    => HsContext name
674    -> Located name
675    -> [LHsTyVarBndr name]
676    -> Maybe [LHsType name]
677    -> SDoc
678 pp_decl_head context thing tyvars Nothing       -- no explicit type patterns
679   = hsep [pprHsContext context, ppr thing, interppSP tyvars]
680 pp_decl_head context thing _      (Just typats) -- explicit type patterns
681   = hsep [ pprHsContext context, ppr thing
682          , hsep (map (pprParendHsType.unLoc) typats)]
683
684 pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
685 pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
686   = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
687 pp_condecls cs                    -- In H98 syntax
688   = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
689
690 pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
691 pp_tydecl True  pp_head _ _
692   = pp_head
693 pp_tydecl False pp_head pp_decl_rhs derivings
694   = hang pp_head 4 (sep [
695       pp_decl_rhs,
696       case derivings of
697         Nothing -> empty
698         Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
699     ])
700
701 instance Outputable NewOrData where
702   ppr NewType  = ptext (sLit "newtype")
703   ppr DataType = ptext (sLit "data")
704 \end{code}
705
706
707 %************************************************************************
708 %*                                                                      *
709 \subsection[ConDecl]{A data-constructor declaration}
710 %*                                                                      *
711 %************************************************************************
712
713 \begin{code}
714 type LConDecl name = Located (ConDecl name)
715
716 -- data T b = forall a. Eq a => MkT a b
717 --   MkT :: forall b a. Eq a => MkT a b
718
719 -- data T b where
720 --      MkT1 :: Int -> T Int
721
722 -- data T = Int `MkT` Int
723 --        | MkT2
724
725 -- data T a where
726 --      Int `MkT` Int :: T Int
727
728 data ConDecl name
729   = ConDecl
730     { con_name      :: Located name
731         -- ^ Constructor name.  This is used for the DataCon itself, and for
732         -- the user-callable wrapper Id.
733
734     , con_explicit  :: HsExplicitFlag
735         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
736
737     , con_qvars     :: [LHsTyVarBndr name]
738         -- ^ Type variables.  Depending on 'con_res' this describes the
739         -- following entities
740         --
741         --  - ResTyH98:  the constructor's *existential* type variables
742         --  - ResTyGADT: *all* the constructor's quantified type variables
743         --
744         -- If con_explicit is Implicit, then con_qvars is irrelevant
745         -- until after renaming.  
746
747     , con_cxt       :: LHsContext name
748         -- ^ The context.  This /does not/ include the \"stupid theta\" which
749         -- lives only in the 'TyData' decl.
750
751     , con_details   :: HsConDeclDetails name
752         -- ^ The main payload
753
754     , con_res       :: ResType name
755         -- ^ Result type of the constructor
756
757     , con_doc       :: Maybe LHsDocString
758         -- ^ A possible Haddock comment.
759
760     , con_old_rec :: Bool   
761         -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
762         --                             GADT-style record decl   C { blah } :: T a b
763         -- Remove this when we no longer parse this stuff, and hence do not
764         -- need to report decprecated use
765     } deriving (Data, Typeable)
766
767 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
768
769 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
770 hsConDeclArgTys (PrefixCon tys)    = tys
771 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
772 hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds
773
774 data ResType name
775    = ResTyH98           -- Constructor was declared using Haskell 98 syntax
776    | ResTyGADT (LHsType name)   -- Constructor was declared using GADT-style syntax,
777                                 --      and here is its result type
778    deriving (Data, Typeable)
779
780 instance OutputableBndr name => Outputable (ResType name) where
781          -- Debugging only
782    ppr ResTyH98 = ptext (sLit "ResTyH98")
783    ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
784 \end{code}
785
786
787 \begin{code}
788 instance (OutputableBndr name) => Outputable (ConDecl name) where
789     ppr = pprConDecl
790
791 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
792 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
793                     , con_cxt = cxt, con_details = details
794                     , con_res = ResTyH98, con_doc = doc })
795   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
796   where
797     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
798     ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
799     ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
800
801 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
802                     , con_cxt = cxt, con_details = PrefixCon arg_tys
803                     , con_res = ResTyGADT res_ty })
804   = ppr con <+> dcolon <+> 
805     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
806   where
807     mk_fun_ty a b = noLoc (HsFunTy a b)
808
809 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
810                     , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
811   = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt, 
812          pprConDeclFields fields <+> arrow <+> ppr res_ty]
813
814 pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
815   = pprPanic "pprConDecl" (ppr con)
816         -- In GADT syntax we don't allow infix constructors
817 \end{code}
818
819 %************************************************************************
820 %*                                                                      *
821 \subsection[InstDecl]{An instance declaration}
822 %*                                                                      *
823 %************************************************************************
824
825 \begin{code}
826 type LInstDecl name = Located (InstDecl name)
827
828 data InstDecl name
829   = InstDecl    (LHsType name)  -- Context => Class Instance-type
830                                 -- Using a polytype means that the renamer conveniently
831                                 -- figures out the quantified type variables for us.
832                 (LHsBinds name)
833                 [LSig name]     -- User-supplied pragmatic info
834                 [LTyClDecl name]-- Associated types (ie, 'TyData' and
835                                 -- 'TySynonym' only)
836   deriving (Data, Typeable)
837
838 instance (OutputableBndr name) => Outputable (InstDecl name) where
839     ppr (InstDecl inst_ty binds sigs ats)
840       | null sigs && null ats && isEmptyBag binds  -- No "where" part
841       = top_matter
842
843       | otherwise       -- Laid out
844       = vcat [ top_matter <+> ptext (sLit "where")
845              , nest 2 $ pprDeclList (map ppr ats ++
846                                      pprLHsBindsForUser binds sigs) ]
847       where
848         top_matter = ptext (sLit "instance") <+> ppr inst_ty
849
850 -- Extract the declarations of associated types from an instance
851 --
852 instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
853 instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
854 \end{code}
855
856 %************************************************************************
857 %*                                                                      *
858 \subsection[DerivDecl]{A stand-alone instance deriving declaration}
859 %*                                                                      *
860 %************************************************************************
861
862 \begin{code}
863 type LDerivDecl name = Located (DerivDecl name)
864
865 data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
866   deriving (Data, Typeable)
867
868 instance (OutputableBndr name) => Outputable (DerivDecl name) where
869     ppr (DerivDecl ty) 
870         = hsep [ptext (sLit "deriving instance"), ppr ty]
871 \end{code}
872
873 %************************************************************************
874 %*                                                                      *
875 \subsection[DefaultDecl]{A @default@ declaration}
876 %*                                                                      *
877 %************************************************************************
878
879 There can only be one default declaration per module, but it is hard
880 for the parser to check that; we pass them all through in the abstract
881 syntax, and that restriction must be checked in the front end.
882
883 \begin{code}
884 type LDefaultDecl name = Located (DefaultDecl name)
885
886 data DefaultDecl name
887   = DefaultDecl [LHsType name]
888   deriving (Data, Typeable)
889
890 instance (OutputableBndr name)
891               => Outputable (DefaultDecl name) where
892
893     ppr (DefaultDecl tys)
894       = ptext (sLit "default") <+> parens (interpp'SP tys)
895 \end{code}
896
897 %************************************************************************
898 %*                                                                      *
899 \subsection{Foreign function interface declaration}
900 %*                                                                      *
901 %************************************************************************
902
903 \begin{code}
904
905 -- foreign declarations are distinguished as to whether they define or use a
906 -- Haskell name
907 --
908 --  * the Boolean value indicates whether the pre-standard deprecated syntax
909 --   has been used
910 --
911 type LForeignDecl name = Located (ForeignDecl name)
912
913 data ForeignDecl name
914   = ForeignImport (Located name) (LHsType name) ForeignImport  -- defines name
915   | ForeignExport (Located name) (LHsType name) ForeignExport  -- uses name
916   deriving (Data, Typeable)
917
918 -- Specification Of an imported external entity in dependence on the calling
919 -- convention 
920 --
921 data ForeignImport = -- import of a C entity
922                      --
923                      --  * the two strings specifying a header file or library
924                      --   may be empty, which indicates the absence of a
925                      --   header or object specification (both are not used
926                      --   in the case of `CWrapper' and when `CFunction'
927                      --   has a dynamic target)
928                      --
929                      --  * the calling convention is irrelevant for code
930                      --   generation in the case of `CLabel', but is needed
931                      --   for pretty printing 
932                      --
933                      --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
934                      --
935                      CImport  CCallConv       -- ccall or stdcall
936                               Safety          -- interruptible, safe or unsafe
937                               FastString      -- name of C header
938                               CImportSpec     -- details of the C entity
939   deriving (Data, Typeable)
940
941 -- details of an external C entity
942 --
943 data CImportSpec = CLabel    CLabelString     -- import address of a C label
944                  | CFunction CCallTarget      -- static or dynamic function
945                  | CWrapper                   -- wrapper to expose closures
946                                               -- (former f.e.d.)
947   deriving (Data, Typeable)
948
949 -- specification of an externally exported entity in dependence on the calling
950 -- convention
951 --
952 data ForeignExport = CExport  CExportSpec    -- contains the calling convention
953   deriving (Data, Typeable)
954
955 -- pretty printing of foreign declarations
956 --
957
958 instance OutputableBndr name => Outputable (ForeignDecl name) where
959   ppr (ForeignImport n ty fimport) =
960     hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
961        2 (dcolon <+> ppr ty)
962   ppr (ForeignExport n ty fexport) =
963     hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
964        2 (dcolon <+> ppr ty)
965
966 instance Outputable ForeignImport where
967   ppr (CImport  cconv safety header spec) =
968     ppr cconv <+> ppr safety <+> 
969     char '"' <> pprCEntity spec <> char '"'
970     where
971       pp_hdr = if nullFS header then empty else ftext header
972
973       pprCEntity (CLabel lbl) = 
974         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
975       pprCEntity (CFunction (StaticTarget lbl _)) = 
976         ptext (sLit "static") <+> pp_hdr <+> ppr lbl
977       pprCEntity (CFunction (DynamicTarget)) =
978         ptext (sLit "dynamic")
979       pprCEntity (CWrapper) = ptext (sLit "wrapper")
980
981 instance Outputable ForeignExport where
982   ppr (CExport  (CExportStatic lbl cconv)) = 
983     ppr cconv <+> char '"' <> ppr lbl <> char '"'
984 \end{code}
985
986
987 %************************************************************************
988 %*                                                                      *
989 \subsection{Transformation rules}
990 %*                                                                      *
991 %************************************************************************
992
993 \begin{code}
994 type LRuleDecl name = Located (RuleDecl name)
995
996 data RuleDecl name
997   = HsRule                      -- Source rule
998         RuleName                -- Rule name
999         Activation
1000         [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
1001         (Located (HsExpr name)) -- LHS
1002         NameSet                 -- Free-vars from the LHS
1003         (Located (HsExpr name)) -- RHS
1004         NameSet                 -- Free-vars from the RHS
1005   deriving (Data, Typeable)
1006
1007 data RuleBndr name
1008   = RuleBndr (Located name)
1009   | RuleBndrSig (Located name) (LHsType name)
1010   deriving (Data, Typeable)
1011
1012 collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
1013 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
1014
1015 instance OutputableBndr name => Outputable (RuleDecl name) where
1016   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
1017         = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
1018                nest 4 (pp_forall <+> pprExpr (unLoc lhs)), 
1019                nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
1020         where
1021           pp_forall | null ns   = empty
1022                     | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
1023
1024 instance OutputableBndr name => Outputable (RuleBndr name) where
1025    ppr (RuleBndr name) = ppr name
1026    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
1027 \end{code}
1028
1029
1030 %************************************************************************
1031 %*                                                                      *
1032 \subsection{Vectorisation declarations}
1033 %*                                                                      *
1034 %************************************************************************
1035
1036 A vectorisation pragma, one of
1037
1038   {-# VECTORISE f = closure1 g (scalar_map g) #-}
1039   {-# VECTORISE SCALAR f #-}
1040   {-# NOVECTORISE f #-}
1041
1042   {-# VECTORISE type T = ty #-}
1043   {-# VECTORISE SCALAR type T #-}
1044   
1045 \begin{code}
1046 type LVectDecl name = Located (VectDecl name)
1047
1048 data VectDecl name
1049   = HsVect
1050       (Located name)
1051       (Maybe (LHsExpr name))    -- 'Nothing' => SCALAR declaration
1052   | HsNoVect
1053       (Located name)
1054   | HsVectTypeIn                -- pre type-checking
1055       (Located name)
1056       (Maybe (LHsType name))    -- 'Nothing' => SCALAR declaration
1057   | HsVectTypeOut               -- post type-checking
1058       TyCon
1059       (Maybe Type)              -- 'Nothing' => SCALAR declaration
1060   deriving (Data, Typeable)
1061
1062 lvectDeclName :: NamedThing name => LVectDecl name -> Name
1063 lvectDeclName (L _ (HsVect        (L _ name) _)) = getName name
1064 lvectDeclName (L _ (HsNoVect      (L _ name)))   = getName name
1065 lvectDeclName (L _ (HsVectTypeIn  (L _ name) _)) = getName name
1066 lvectDeclName (L _ (HsVectTypeOut tycon _))      = getName tycon
1067
1068 instance OutputableBndr name => Outputable (VectDecl name) where
1069   ppr (HsVect v Nothing)
1070     = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ]
1071   ppr (HsVect v (Just rhs))
1072     = sep [text "{-# VECTORISE" <+> ppr v,
1073            nest 4 $ 
1074              pprExpr (unLoc rhs) <+> text "#-}" ]
1075   ppr (HsNoVect v)
1076     = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
1077   ppr (HsVectTypeIn t Nothing)
1078     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1079   ppr (HsVectTypeIn t (Just ty))
1080     = sep [text "{-# VECTORISE type" <+> ppr t,
1081            nest 4 $ 
1082              ppr (unLoc ty) <+> text "#-}" ]
1083   ppr (HsVectTypeOut t Nothing)
1084     = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
1085   ppr (HsVectTypeOut t (Just ty))
1086     = sep [text "{-# VECTORISE type" <+> ppr t,
1087            nest 4 $ 
1088              ppr ty <+> text "#-}" ]
1089 \end{code}
1090
1091 %************************************************************************
1092 %*                                                                      *
1093 \subsection[DocDecl]{Document comments}
1094 %*                                                                      *
1095 %************************************************************************
1096
1097 \begin{code}
1098
1099 type LDocDecl = Located (DocDecl)
1100
1101 data DocDecl
1102   = DocCommentNext HsDocString
1103   | DocCommentPrev HsDocString
1104   | DocCommentNamed String HsDocString
1105   | DocGroup Int HsDocString
1106   deriving (Data, Typeable)
1107  
1108 -- Okay, I need to reconstruct the document comments, but for now:
1109 instance Outputable DocDecl where
1110   ppr _ = text "<document comment>"
1111
1112 docDeclDoc :: DocDecl -> HsDocString
1113 docDeclDoc (DocCommentNext d) = d
1114 docDeclDoc (DocCommentPrev d) = d
1115 docDeclDoc (DocCommentNamed _ d) = d
1116 docDeclDoc (DocGroup _ d) = d
1117
1118 \end{code}
1119
1120 %************************************************************************
1121 %*                                                                      *
1122 \subsection[DeprecDecl]{Deprecations}
1123 %*                                                                      *
1124 %************************************************************************
1125
1126 We use exported entities for things to deprecate.
1127
1128 \begin{code}
1129 type LWarnDecl name = Located (WarnDecl name)
1130
1131 data WarnDecl name = Warning name WarningTxt
1132   deriving (Data, Typeable)
1133
1134 instance OutputableBndr name => Outputable (WarnDecl name) where
1135     ppr (Warning thing txt)
1136       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
1137 \end{code}
1138
1139 %************************************************************************
1140 %*                                                                      *
1141 \subsection[AnnDecl]{Annotations}
1142 %*                                                                      *
1143 %************************************************************************
1144
1145 \begin{code}
1146 type LAnnDecl name = Located (AnnDecl name)
1147
1148 data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
1149   deriving (Data, Typeable)
1150
1151 instance (OutputableBndr name) => Outputable (AnnDecl name) where
1152     ppr (HsAnnotation provenance expr) 
1153       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
1154
1155
1156 data AnnProvenance name = ValueAnnProvenance name
1157                         | TypeAnnProvenance name
1158                         | ModuleAnnProvenance
1159   deriving (Data, Typeable)
1160
1161 annProvenanceName_maybe :: AnnProvenance name -> Maybe name
1162 annProvenanceName_maybe (ValueAnnProvenance name) = Just name
1163 annProvenanceName_maybe (TypeAnnProvenance name)  = Just name
1164 annProvenanceName_maybe ModuleAnnProvenance       = Nothing
1165
1166 -- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough
1167 modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after)
1168 modifyAnnProvenanceNameM fm prov =
1169     case prov of
1170             ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name)
1171             TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name)
1172             ModuleAnnProvenance -> return ModuleAnnProvenance
1173
1174 pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
1175 pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
1176 pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
1177 pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
1178 \end{code}