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