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