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