HsDecls.lhs 38.5 KB
Newer Older
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 10 11 12
-- | Abstract syntax of global declarations.
--
-- Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
13
module HsDecls (
14 15 16 17 18
  -- * Toplevel declarations
  HsDecl(..), LHsDecl,
  -- ** Class or type declarations
  TyClDecl(..), LTyClDecl,
  isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
19
  isFamInstDecl, tcdName, tyClDeclTyVars,
20 21 22 23 24 25 26 27 28
  countTyClDecls,
  -- ** Instance declarations
  InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
  instDeclATs,
  -- ** Standalone deriving declarations
  DerivDecl(..), LDerivDecl,
  -- ** @RULE@ declarations
  RuleDecl(..), LRuleDecl, RuleBndr(..),
  collectRuleBndrSigTys,
29 30
  -- ** @VECTORISE@ declarations
  VectDecl(..), LVectDecl,
31 32 33 34 35 36
  -- ** @default@ declarations
  DefaultDecl(..), LDefaultDecl,
  -- ** Top-level template haskell splice
  SpliceDecl(..),
  -- ** Foreign function interface declarations
  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
37
  CImportSpec(..),
38
  -- ** Data-constructor declarations
39
  ConDecl(..), LConDecl, ResType(..), 
40
  HsConDeclDetails, hsConDeclArgTys, 
41 42 43 44
  -- ** Document comments
  DocDecl(..), LDocDecl, docDeclDoc,
  -- ** Deprecations
  WarnDecl(..),  LWarnDecl,
45 46 47
  -- ** Annotations
  AnnDecl(..), LAnnDecl, 
  AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
48 49

  -- * Grouping
50 51
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
    ) where
52 53

-- friends:
54
import {-# SOURCE #-}	HsExpr( LHsExpr, HsExpr, pprExpr )
55 56
	-- Because Expr imports Decls via HsBracket

57 58
import HsBinds
import HsPat
59
import HsTypes
60 61 62 63 64
import HsDoc
import NameSet
import {- Kind parts of -} Type
import BasicTypes
import ForeignCall
65 66

-- others:
67
import Class
68
import Outputable	
69 70
import Util
import SrcLoc
rrt's avatar
rrt committed
71
import FastString
72

73
import Control.Monad    ( liftM )
74
import Data.Data
75
import Data.Maybe       ( isJust )
76 77
\end{code}

78 79 80 81 82 83 84
%************************************************************************
%*									*
\subsection[HsDecl]{Declarations}
%*									*
%************************************************************************

\begin{code}
85 86
type LHsDecl id = Located (HsDecl id)

87
-- | A Haskell Declaration
88
data HsDecl id
89 90
  = TyClD	(TyClDecl id)     -- ^ A type or class declaration.
  | InstD	(InstDecl  id)    -- ^ An instance declaration.
91
  | DerivD      (DerivDecl id)
92
  | ValD	(HsBind id)
93
  | SigD	(Sig id)
94 95
  | DefD	(DefaultDecl id)
  | ForD        (ForeignDecl id)
Ian Lynagh's avatar
Ian Lynagh committed
96
  | WarningD	(WarnDecl id)
97
  | AnnD	(AnnDecl id)
98
  | RuleD	(RuleDecl id)
99
  | VectD	(VectDecl id)
100
  | SpliceD	(SpliceDecl id)
101
  | DocD	(DocDecl)
102
  | QuasiQuoteD	(HsQuasiQuote id)
103
  deriving (Data, Typeable)
104

105 106

-- NB: all top-level fixity decls are contained EITHER
107
-- EITHER SigDs
108 109 110 111 112 113 114 115 116 117
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
-- 	a) data constructors
-- 	b) class methods (but they can be also done in the
-- 		signatures of class decls)
--	c) imported functions (that have an IfacSig)
--	d) top level decls
--
-- The latter is for class methods only
118

119
-- | A 'HsDecl' is categorised into a 'HsGroup' before being
120 121 122
-- fed to the renamer.
data HsGroup id
  = HsGroup {
123
	hs_valds  :: HsValBinds id,
124 125 126 127 128 129

	hs_tyclds :: [[LTyClDecl id]],	
		-- A list of mutually-recursive groups
		-- Parser generates a singleton list;
		-- renamer does dependency analysis

130
	hs_instds :: [LInstDecl id],
131
        hs_derivds :: [LDerivDecl id],
132

133
	hs_fixds  :: [LFixitySig id],
134 135 136
		-- Snaffled out of both top-level fixity signatures,
		-- and those in class declarations

137 138 139 140 141 142
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
        hs_warnds :: [LWarnDecl id],
        hs_annds  :: [LAnnDecl id],
        hs_ruleds :: [LRuleDecl id],
        hs_vects  :: [LVectDecl id],
143

144
        hs_docs   :: [LDocDecl]
145
  } deriving (Data, Typeable)
146

147 148 149 150
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

151
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
152
		       hs_fixds = [], hs_defds = [], hs_annds = [],
153
		       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
154 155
		       hs_valds = error "emptyGroup hs_valds: Can't happen",
                       hs_docs = [] }
156 157 158 159

appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
appendGroups 
    HsGroup { 
160 161 162
        hs_valds  = val_groups1,
        hs_tyclds = tyclds1, 
        hs_instds = instds1,
163
        hs_derivds = derivds1,
164 165 166 167 168 169 170
        hs_fixds  = fixds1, 
        hs_defds  = defds1,
        hs_annds  = annds1,
        hs_fords  = fords1, 
        hs_warnds = warnds1,
        hs_ruleds = rulds1,
        hs_vects = vects1,
171
  hs_docs   = docs1 }
172
    HsGroup { 
173 174 175
        hs_valds  = val_groups2,
        hs_tyclds = tyclds2, 
        hs_instds = instds2,
176
        hs_derivds = derivds2,
177 178 179 180 181 182 183 184
        hs_fixds  = fixds2, 
        hs_defds  = defds2,
        hs_annds  = annds2,
        hs_fords  = fords2, 
        hs_warnds = warnds2,
        hs_ruleds = rulds2,
        hs_vects  = vects2,
        hs_docs   = docs2 }
185 186
  = 
    HsGroup { 
187 188 189
        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
        hs_tyclds = tyclds1 ++ tyclds2, 
        hs_instds = instds1 ++ instds2,
190
        hs_derivds = derivds1 ++ derivds2,
191 192 193 194 195 196 197 198
        hs_fixds  = fixds1 ++ fixds2,
        hs_annds  = annds1 ++ annds2,
        hs_defds  = defds1 ++ defds2,
        hs_fords  = fords1 ++ fords2, 
        hs_warnds = warnds1 ++ warnds2,
        hs_ruleds = rulds1 ++ rulds2,
        hs_vects  = vects1 ++ vects2,
        hs_docs   = docs1  ++ docs2 }
199 200 201
\end{code}

\begin{code}
202
instance OutputableBndr name => Outputable (HsDecl name) where
203 204 205 206 207 208 209 210
    ppr (TyClD dcl)             = ppr dcl
    ppr (ValD binds)            = ppr binds
    ppr (DefD def)              = ppr def
    ppr (InstD inst)            = ppr inst
    ppr (DerivD deriv)          = ppr deriv
    ppr (ForD fd)               = ppr fd
    ppr (SigD sd)               = ppr sd
    ppr (RuleD rd)              = ppr rd
211
    ppr (VectD vect)            = ppr vect
Ian Lynagh's avatar
Ian Lynagh committed
212
    ppr (WarningD wd)           = ppr wd
213
    ppr (AnnD ad)               = ppr ad
214 215
    ppr (SpliceD dd)            = ppr dd
    ppr (DocD doc)              = ppr doc
216
    ppr (QuasiQuoteD qq)        = ppr qq
217 218 219 220 221

instance OutputableBndr name => Outputable (HsGroup name) where
    ppr (HsGroup { hs_valds  = val_decls,
		   hs_tyclds = tycl_decls,
		   hs_instds = inst_decls,
222
                   hs_derivds = deriv_decls,
223
		   hs_fixds  = fix_decls,
Ian Lynagh's avatar
Ian Lynagh committed
224
		   hs_warnds = deprec_decls,
225
		   hs_annds  = ann_decls,
226 227
		   hs_fords  = foreign_decls,
		   hs_defds  = default_decls,
228 229
		   hs_ruleds = rule_decls,
		   hs_vects  = vect_decls })
230 231 232 233
	= vcat_mb empty 
            [ppr_ds fix_decls, ppr_ds default_decls, 
	     ppr_ds deprec_decls, ppr_ds ann_decls,
	     ppr_ds rule_decls,
234
	     ppr_ds vect_decls,
235 236 237
	     if isEmptyValBinds val_decls 
                then Nothing 
                else Just (ppr val_decls),
238 239
	     ppr_ds (concat tycl_decls), 
             ppr_ds inst_decls,
240 241
             ppr_ds deriv_decls,
	     ppr_ds foreign_decls]
242
	where
243
          ppr_ds :: Outputable a => [a] -> Maybe SDoc
244 245 246 247 248 249 250 251
	  ppr_ds [] = Nothing
	  ppr_ds ds = Just (vcat (map ppr ds))

          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
	  -- Concatenate vertically with white-space between non-blanks
          vcat_mb _    []             = empty
          vcat_mb gap (Nothing : ds) = vcat_mb gap ds
          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
252

253 254 255 256 257
data SpliceDecl id 
  = SpliceDecl			-- Top level splice
        (Located (HsExpr id))
        HsExplicitFlag		-- Explicit <=> $(f x y)
				-- Implicit <=> f x y,  i.e. a naked top level expression
258
    deriving (Data, Typeable)
259 260

instance OutputableBndr name => Outputable (SpliceDecl name) where
261
   ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
262 263
\end{code}

264

265 266 267 268 269 270
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

271 272 273
		--------------------------------
			THE NAMING STORY
		--------------------------------
274

275 276
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
277 278 279

"Implicit" (or "system") binders
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
280 281 282 283 284 285 286 287 288
  Each data type decl defines 
	a worker name for each constructor
	to-T and from-T convertors
  Each class decl defines
	a tycon for the class
	a data constructor for that tycon
	the worker for that constructor
	a selector for each superclass

289 290
All have occurrence names that are derived uniquely from their parent
declaration.
291 292 293 294 295 296 297 298 299

None of these get separate definitions in an interface file; they are
fully defined by the data or class decl.  But they may *occur* in
interface files, of course.  Any such occurrence must haul in the
relevant type or class decl.

Plan of attack:
 - Ensure they "point to" the parent data/class decl 
   when loading that decl from an interface file
300 301 302 303 304
   (See RnHiFiles.getSysBinders)

 - When typechecking the decl, we build the implicit TyCons and Ids.
   When doing so we look them up in the name cache (RnEnv.lookupSysName),
   to ensure correct module and provenance is set
305

306 307
These are the two places that we have to conjure up the magic derived
names.  (The actual magic is in OccName.mkWorkerOcc, etc.)
308

309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
Default methods
~~~~~~~~~~~~~~~
 - Occurrence name is derived uniquely from the method name
   E.g. $dmmax

 - If there is a default method name at all, it's recorded in
   the ClassOpSig (in HsBinds), in the DefMeth field.
   (DefMeth is defined in Class.lhs)

Source-code class decls and interface-code class decls are treated subtly
differently, which has given me a great deal of confusion over the years.
Here's the deal.  (We distinguish the two cases because source-code decls
have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.

In *source-code* class declarations:
324

325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
 - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
   This is done by RdrHsSyn.mkClassOpSigDM

 - The renamer renames it to a Name

 - During typechecking, we generate a binding for each $dm for 
   which there's a programmer-supplied default method:
	class Foo a where
	  op1 :: <type>
	  op2 :: <type>
	  op1 = ...
   We generate a binding for $dmop1 but not for $dmop2.
   The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
   The Name for $dmop2 is simply discarded.

In *interface-file* class declarations:
  - When parsing, we see if there's an explicit programmer-supplied default method
    because there's an '=' sign to indicate it:
	class Foo a where
	  op1 = :: <type>	-- NB the '='
  	  op2   :: <type>
    We use this info to generate a DefMeth with a suitable RdrName for op1,
    and a NoDefMeth for op2
  - The interface file has a separate definition for $dmop1, with unfolding etc.
  - The renamer renames it to a Name.
  - The renamer treats $dmop1 as a free variable of the declaration, so that
    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)  
    This doesn't happen for source code class decls, because they *bind* the default method.

Dictionary functions
~~~~~~~~~~~~~~~~~~~~
Each instance declaration gives rise to one dictionary function binding.

The type checker makes up new source-code instance declarations
(e.g. from 'deriving' or generic default methods --- see
TcInstDcls.tcInstDecls1).  So we can't generate the names for
dictionary functions in advance (we don't know how many we need).

On the other hand for interface-file instance declarations, the decl
specifies the name of the dictionary function, and it has a binding elsewhere
in the interface file:
	instance {Eq Int} = dEqInt
	dEqInt :: {Eq Int} <pragma info>

So again we treat source code and interface file code slightly differently.

Source code:
  - Source code instance decls have a Nothing in the (Maybe name) field
    (see data InstDecl below)

  - The typechecker makes up a Local name for the dict fun for any source-code
    instance decl, whether it comes from a source-code instance decl, or whether
    the instance decl is derived from some other construct (e.g. 'deriving').

  - The occurrence name it chooses is derived from the instance decl (just for 
    documentation really) --- e.g. dNumInt.  Two dict funs may share a common
    occurrence name, but will have different uniques.  E.g.
	instance Foo [Int]  where ...
	instance Foo [Bool] where ...
    These might both be dFooList

386
  - The CoreTidy phase externalises the name, and ensures the occurrence name is
387 388 389 390 391 392 393 394 395 396 397 398
    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.

  - We can take this relaxed approach (changing the occurrence name later) 
    because dict fun Ids are not captured in a TyCon or Class (unlike default
    methods, say).  Instead, they are kept separately in the InstEnv.  This
    makes it easy to adjust them after compiling a module.  (Once we've finished
    compiling that module, they don't change any more.)


Interface file code:
  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
    in the (Maybe name) field.
399

400 401
  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
    suck in the dfun binding
402 403


404
\begin{code}
405 406
-- Representation of indexed types
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
407 408 409
-- Family kind signatures are represented by the variant `TyFamily'.  It
-- covers "type family", "newtype family", and "data family" declarations,
-- distinguished by the value of the field `tcdFlavour'.
410 411 412
--
-- Indexed types are represented by 'TyData' and 'TySynonym' using the field
-- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
413 414 415 416 417
--
--   * If it is 'Nothing', we have a *vanilla* data type declaration or type
--     synonym declaration and 'tcdVars' contains the type parameters of the
--     type constructor.
--
418
--   * If it is 'Just pats', we have the definition of an indexed type.  Then,
419
--     'pats' are type patterns for the type-indexes of the type constructor
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
420
--     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
421 422
--     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
--     *not* 'length tcdVars'.
423 424 425
--
-- In both cases, 'tcdVars' collects all variables we need to quantify over.

426 427
type LTyClDecl name = Located (TyClDecl name)

428
-- | A type or class declaration.
429
data TyClDecl name
430 431
  = ForeignType { 
		tcdLName    :: Located name,
432
		tcdExtName  :: Maybe FastString
433 434
    }

435

436 437
  | -- | @type/data family T :: *->*@
    TyFamily {  tcdFlavour:: FamilyFlavour,	        -- type or data
438 439 440 441
		tcdLName  :: Located name,	        -- type constructor
		tcdTyVars :: [LHsTyVarBndr name],	-- type variables
		tcdKind   :: Maybe Kind			-- result kind
    }
442

443

444 445 446 447 448 449 450 451
  | -- | Declares a data type or newtype, giving its construcors
    -- @
    -- 	data/newtype T a = <constrs>
    --	data/newtype instance T [a] = <constrs>
    -- @
    TyData {	tcdND     :: NewOrData,
		tcdCtxt   :: LHsContext name,	 	-- ^ Context
		tcdLName  :: Located name,	 	-- ^ Type constructor
452

453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474
		tcdTyVars :: [LHsTyVarBndr name], 	-- ^ Type variables
			
		tcdTyPats :: Maybe [LHsType name],
                        -- ^ Type patterns.
                        --
			-- @Just [t1..tn]@ for @data instance T t1..tn = ...@
			--	in this case @tcdTyVars = fv( tcdTyPats )@.
			-- @Nothing@ for everything else.

		tcdKindSig:: Maybe Kind,
                        -- ^ Optional kind signature.
                        --
			-- @(Just k)@ for a GADT-style @data@, or @data
			-- instance@ decl with explicit kind sig

		tcdCons	  :: [LConDecl name],
                        -- ^ Data constructors
                        --
			-- For @data T a = T1 | T2 a@
                        --   the 'LConDecl's all have 'ResTyH98'.
			-- For @data T a where { T1 :: T a }@
                        --   the 'LConDecls' all have 'ResTyGADT'.
475

476
		tcdDerivs :: Maybe [LHsType name]
477 478 479
			-- ^ Derivings; @Nothing@ => not specified,
			-- 	        @Just []@ => derive exactly what is asked
                        --
480
			-- These "types" must be of form
481
                        -- @
482
			--	forall ab. C ty1 ty2
483
                        -- @
484 485
			-- Typically the foralls and ty args are empty, but they
			-- are non-empty for the newtype-deriving case
486
    }
487

488 489 490
  | TySynonym {	tcdLName  :: Located name,	        -- ^ type constructor
		tcdTyVars :: [LHsTyVarBndr name],	-- ^ type variables
		tcdTyPats :: Maybe [LHsType name],	-- ^ Type patterns
491 492 493
			-- See comments for tcdTyPats in TyData
			-- 'Nothing' => vanilla type synonym

494
		tcdSynRhs :: LHsType name	        -- ^ synonym expansion
495 496
    }

497 498 499 500 501 502 503
  | ClassDecl {	tcdCtxt    :: LHsContext name, 	 	-- ^ Context...
		tcdLName   :: Located name,	    	-- ^ Name of the class
		tcdTyVars  :: [LHsTyVarBndr name],	-- ^ Class type variables
		tcdFDs     :: [Located (FunDep name)],	-- ^ Functional deps
		tcdSigs    :: [LSig name],		-- ^ Methods' signatures
		tcdMeths   :: LHsBinds name,		-- ^ Default methods
		tcdATs	   :: [LTyClDecl name],		-- ^ Associated types; ie
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
504 505 506
							--   only 'TyFamily' and
							--   'TySynonym'; the
                                                        --   latter for defaults
507
		tcdDocs    :: [LDocDecl]		-- ^ Haddock docs
508
    }
509
  deriving (Data, Typeable)
510 511

data NewOrData
512 513
  = NewType			-- ^ @newtype Blah ...@
  | DataType			-- ^ @data Blah ...@
514
  deriving( Eq, Data, Typeable )		-- Needed because Demand derives Eq
515 516

data FamilyFlavour
517 518
  = TypeFamily			-- ^ @type family ...@
  | DataFamily	                -- ^ @data family ...@
519
  deriving (Data, Typeable)
520 521 522 523 524
\end{code}

Simple classifiers

\begin{code}
525 526 527
-- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@
-- declaration.
isDataDecl :: TyClDecl name -> Bool
528 529
isDataDecl (TyData {}) = True
isDataDecl _other      = False
530

531 532
-- | type or type instance declaration
isTypeDecl :: TyClDecl name -> Bool
533 534
isTypeDecl (TySynonym {}) = True
isTypeDecl _other	  = False
535

536 537
-- | vanilla Haskell type synonym (ie, not a type instance)
isSynDecl :: TyClDecl name -> Bool
538 539
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
isSynDecl _other	                    = False
540

541 542
-- | type class
isClassDecl :: TyClDecl name -> Bool
543
isClassDecl (ClassDecl {}) = True
544
isClassDecl _              = False
545

546 547
-- | type family declaration
isFamilyDecl :: TyClDecl name -> Bool
548 549 550
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other        = False

551 552
-- | family instance (types, newtypes, and data types)
isFamInstDecl :: TyClDecl name -> Bool
553 554 555 556
isFamInstDecl tydecl
   | isTypeDecl tydecl
     || isDataDecl tydecl = isJust (tcdTyPats tydecl)
   | otherwise	          = False
557 558 559
\end{code}

Dealing with names
560

561
\begin{code}
562 563
tcdName :: TyClDecl name -> name
tcdName decl = unLoc (tcdLName decl)
564

565
tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
566
tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
567 568 569 570
tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ForeignType {})		       = []
571 572 573
\end{code}

\begin{code}
574
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
575
	-- class, synonym decls, data, newtype, family decls, family instances
576
countTyClDecls decls 
577 578 579 580 581 582
 = (count isClassDecl    decls,
    count isSynDecl      decls,  -- excluding...
    count isDataTy       decls,  -- ...family...
    count isNewTy        decls,  -- ...instances
    count isFamilyDecl   decls,
    count isFamInstDecl  decls)
sof's avatar
sof committed
583
 where
584 585
   isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
   isDataTy _                                             = False
sof's avatar
sof committed
586
   
587 588
   isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
   isNewTy _                                            = False
589 590 591
\end{code}

\begin{code}
592 593
instance OutputableBndr name
	      => Outputable (TyClDecl name) where
594

595
    ppr (ForeignType {tcdLName = ltycon})
Ian Lynagh's avatar
Ian Lynagh committed
596
	= hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
597

598 599 600
    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
		   tcdTyVars = tyvars, tcdKind = mb_kind})
      = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
601
        where
602
	  pp_flavour = case flavour of
Ian Lynagh's avatar
Ian Lynagh committed
603 604
		         TypeFamily -> ptext (sLit "type family")
			 DataFamily -> ptext (sLit "data family")
605 606 607 608

          pp_kind = case mb_kind of
		      Nothing   -> empty
		      Just kind -> dcolon <+> pprKind kind
609 610 611

    ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
		    tcdSynRhs = mono_ty})
Ian Lynagh's avatar
Ian Lynagh committed
612 613
      = hang (ptext (sLit "type") <+> 
	      (if isJust typats then ptext (sLit "instance") else empty) <+>
614
	      pp_decl_head [] ltycon tyvars typats <+> 
615
	      equals)
616
	     4 (ppr mono_ty)
617

618
    ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
619 620
		 tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
		 tcdCons = condecls, tcdDerivs = derivings})
621 622
      = pp_tydecl (null condecls && isJust mb_sig) 
                  (ppr new_or_data <+> 
Ian Lynagh's avatar
Ian Lynagh committed
623
		   (if isJust typats then ptext (sLit "instance") else empty) <+>
624
		   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
625
		   ppr_sigx mb_sig)
626
		  (pp_condecls condecls)
627
		  derivings
628
      where
629 630
	ppr_sigx Nothing     = empty
	ppr_sigx (Just kind) = dcolon <+> pprKind kind
631

632
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
633
		    tcdFDs  = fds, 
634 635
		    tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
      | null sigs && null ats  -- No "where" part
636 637 638
      = top_matter

      | otherwise	-- Laid out
Ian Lynagh's avatar
Ian Lynagh committed
639
      = sep [hsep [top_matter, ptext (sLit "where {")],
640 641 642 643
	     nest 4 (sep [ sep (map ppr_semi ats)
			 , sep (map ppr_semi sigs)
			 , pprLHsBinds methods
			 , char '}'])]
644
      where
Ian Lynagh's avatar
Ian Lynagh committed
645
        top_matter    =     ptext (sLit "class") 
646 647
		        <+> pp_decl_head (unLoc context) lclas tyvars Nothing
		        <+> pprFundeps (map unLoc fds)
648
        ppr_semi :: Outputable a => a -> SDoc
649
	ppr_semi decl = ppr decl <> semi
650

651 652 653 654
pp_decl_head :: OutputableBndr name
   => HsContext name
   -> Located name
   -> [LHsTyVarBndr name]
655
   -> Maybe [LHsType name]
656
   -> SDoc
657
pp_decl_head context thing tyvars Nothing	-- no explicit type patterns
658
  = hsep [pprHsContext context, ppr thing, interppSP tyvars]
659 660 661 662
pp_decl_head context thing _      (Just typats) -- explicit type patterns
  = hsep [ pprHsContext context, ppr thing
	 , hsep (map (pprParendHsType.unLoc) typats)]

663
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
664
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
Ian Lynagh's avatar
Ian Lynagh committed
665
  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
666
pp_condecls cs 			  -- In H98 syntax
Ian Lynagh's avatar
Ian Lynagh committed
667
  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
668

669 670
pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
pp_tydecl True  pp_head _ _
671 672
  = pp_head
pp_tydecl False pp_head pp_decl_rhs derivings
sof's avatar
sof committed
673
  = hang pp_head 4 (sep [
674 675 676
      pp_decl_rhs,
      case derivings of
        Nothing -> empty
Ian Lynagh's avatar
Ian Lynagh committed
677
	Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
678
    ])
679 680

instance Outputable NewOrData where
Ian Lynagh's avatar
Ian Lynagh committed
681 682
  ppr NewType  = ptext (sLit "newtype")
  ppr DataType = ptext (sLit "data")
683 684 685 686 687 688 689 690 691 692
\end{code}


%************************************************************************
%*									*
\subsection[ConDecl]{A data-constructor declaration}
%*									*
%************************************************************************

\begin{code}
693 694
type LConDecl name = Located (ConDecl name)

695 696 697 698 699 700 701 702 703 704 705 706
-- data T b = forall a. Eq a => MkT a b
--   MkT :: forall b a. Eq a => MkT a b

-- data T b where
--	MkT1 :: Int -> T Int

-- data T = Int `MkT` Int
--	  | MkT2

-- data T a where
--	Int `MkT` Int :: T Int

707
data ConDecl name
708
  = ConDecl
709 710 711
    { con_name      :: Located name
        -- ^ Constructor name.  This is used for the DataCon itself, and for
        -- the user-callable wrapper Id.
712

713
    , con_explicit  :: HsExplicitFlag
714
        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
715

716 717 718 719
    , con_qvars     :: [LHsTyVarBndr name]
        -- ^ Type variables.  Depending on 'con_res' this describes the
	-- follewing entities
        --
720 721
        --  - ResTyH98:  the constructor's *existential* type variables
        --  - ResTyGADT: *all* the constructor's quantified type variables
722

723 724 725
    , con_cxt       :: LHsContext name
        -- ^ The context.  This /does not/ include the \"stupid theta\" which
	-- lives only in the 'TyData' decl.
726

727 728
    , con_details   :: HsConDeclDetails name
        -- ^ The main payload
729

730 731
    , con_res       :: ResType name
        -- ^ Result type of the constructor
732

733
    , con_doc       :: Maybe LHsDocString
734
        -- ^ A possible Haddock comment.
735 736 737 738 739 740

    , con_old_rec :: Bool   
        -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
	--   	       	               GADT-style record decl   C { blah } :: T a b
	-- Remove this when we no longer parse this stuff, and hence do not
	-- need to report decprecated use
741
    } deriving (Data, Typeable)
742

743 744 745 746 747 748 749
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]

hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys)    = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds

750 751 752 753
data ResType name
   = ResTyH98		-- Constructor was declared using Haskell 98 syntax
   | ResTyGADT (LHsType name)	-- Constructor was declared using GADT-style syntax,
				--	and here is its result type
754
   deriving (Data, Typeable)
755 756 757 758 759

instance OutputableBndr name => Outputable (ResType name) where
	 -- Debugging only
   ppr ResTyH98 = ptext (sLit "ResTyH98")
   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
760 761
\end{code}

762 763

\begin{code}
764
instance (OutputableBndr name) => Outputable (ConDecl name) where
765 766
    ppr = pprConDecl

767
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
768
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
769 770
                    , con_cxt = cxt, con_details = details
                    , con_res = ResTyH98, con_doc = doc })
771
  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
sof's avatar
sof committed
772
  where
773 774 775
    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
    ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
    ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
776

777 778 779
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                    , con_cxt = cxt, con_details = PrefixCon arg_tys
                    , con_res = ResTyGADT res_ty })
780 781
  = ppr con <+> dcolon <+> 
    sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
782 783
  where
    mk_fun_ty a b = noLoc (HsFunTy a b)
sof's avatar
sof committed
784

785 786 787 788
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                    , con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
  = sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt, 
         pprConDeclFields fields <+> arrow <+> ppr res_ty]
789

790
pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
791 792
  = pprPanic "pprConDecl" (ppr con)
	-- In GADT syntax we don't allow infix constructors
793 794 795 796
\end{code}

%************************************************************************
%*									*
797
\subsection[InstDecl]{An instance declaration}
798 799 800 801
%*									*
%************************************************************************

\begin{code}
802 803
type LInstDecl name = Located (InstDecl name)

804
data InstDecl name
805
  = InstDecl	(LHsType name)	-- Context => Class Instance-type
806 807
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.
808
		(LHsBinds name)
809
		[LSig name]	-- User-supplied pragmatic info
810 811
		[LTyClDecl name]-- Associated types (ie, 'TyData' and
				-- 'TySynonym' only)
812
  deriving (Data, Typeable)
813

814
instance (OutputableBndr name) => Outputable (InstDecl name) where
815

816
    ppr (InstDecl inst_ty binds uprags ats)
Ian Lynagh's avatar
Ian Lynagh committed
817
      = vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")]
818 819 820
             , nest 4 $ vcat (map ppr ats)
 	     , nest 4 $ vcat (map ppr uprags)
	     , nest 4 $ pprLHsBinds binds ]
821 822 823

-- Extract the declarations of associated types from an instance
--
824 825
instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
826 827
\end{code}

828 829
%************************************************************************
%*									*
830
\subsection[DerivDecl]{A stand-alone instance deriving declaration}
831 832 833 834 835 836
%*									*
%************************************************************************

\begin{code}
type LDerivDecl name = Located (DerivDecl name)

dreixel's avatar
dreixel committed
837
data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
838
  deriving (Data, Typeable)
839 840

instance (OutputableBndr name) => Outputable (DerivDecl name) where
841
    ppr (DerivDecl ty) 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
842
        = hsep [ptext (sLit "deriving instance"), ppr ty]
843 844
\end{code}

845 846 847 848 849 850 851 852 853 854 855
%************************************************************************
%*									*
\subsection[DefaultDecl]{A @default@ declaration}
%*									*
%************************************************************************

There can only be one default declaration per module, but it is hard
for the parser to check that; we pass them all through in the abstract
syntax, and that restriction must be checked in the front end.

\begin{code}
856 857
type LDefaultDecl name = Located (DefaultDecl name)

858
data DefaultDecl name
859
  = DefaultDecl	[LHsType name]
860
  deriving (Data, Typeable)
861

862
instance (OutputableBndr name)
863 864
	      => Outputable (DefaultDecl name) where

865
    ppr (DefaultDecl tys)
Ian Lynagh's avatar
Ian Lynagh committed
866
      = ptext (sLit "default") <+> parens (interpp'SP tys)
867
\end{code}
868

sof's avatar
sof committed
869 870 871 872 873 874 875
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
chak's avatar
chak committed
876 877 878 879

-- foreign declarations are distinguished as to whether they define or use a
-- Haskell name
--
880
--  * the Boolean value indicates whether the pre-standard deprecated syntax
chak's avatar
chak committed
881 882
--   has been used
--
883 884
type LForeignDecl name = Located (ForeignDecl name)

885
data ForeignDecl name
Simon Marlow's avatar
Simon Marlow committed
886 887
  = ForeignImport (Located name) (LHsType name) ForeignImport  -- defines name
  | ForeignExport (Located name) (LHsType name) ForeignExport  -- uses name
888
  deriving (Data, Typeable)
889

Simon Marlow's avatar
Simon Marlow committed
890
-- Specification Of an imported external entity in dependence on the calling
chak's avatar
chak committed
891 892 893 894
-- convention 
--
data ForeignImport = -- import of a C entity
		     --
895
                     --  * the two strings specifying a header file or library
chak's avatar
chak committed
896 897 898 899 900
                     --   may be empty, which indicates the absence of a
                     --   header or object specification (both are not used
                     --   in the case of `CWrapper' and when `CFunction'
                     --   has a dynamic target)
		     --
901
		     --  * the calling convention is irrelevant for code
chak's avatar
chak committed
902 903 904
		     --   generation in the case of `CLabel', but is needed
		     --   for pretty printing 
		     --
905
		     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
chak's avatar
chak committed
906 907
		     --
		     CImport  CCallConv	      -- ccall or stdcall
908
			      Safety	      -- interruptible, safe or unsafe
chak's avatar
chak committed
909 910
			      FastString      -- name of C header
			      CImportSpec     -- details of the C entity
911
  deriving (Data, Typeable)
chak's avatar
chak committed
912 913 914 915 916 917 918

-- details of an external C entity
--
data CImportSpec = CLabel    CLabelString     -- import address of a C label
		 | CFunction CCallTarget      -- static or dynamic function
		 | CWrapper		      -- wrapper to expose closures
					      -- (former f.e.d.)
919
  deriving (Data, Typeable)
920

chak's avatar
chak committed
921 922 923 924
-- specification of an externally exported entity in dependence on the calling
-- convention
--
data ForeignExport = CExport  CExportSpec    -- contains the calling convention
925
  deriving (Data, Typeable)
chak's avatar
chak committed
926 927 928

-- pretty printing of foreign declarations
--
929

930
instance OutputableBndr name => Outputable (ForeignDecl name) where
Simon Marlow's avatar
Simon Marlow committed
931
  ppr (ForeignImport n ty fimport) =
Ian Lynagh's avatar
Ian Lynagh committed
932
    hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
933
       2 (dcolon <+> ppr ty)
Simon Marlow's avatar
Simon Marlow committed
934
  ppr (ForeignExport n ty fexport) =
Ian Lynagh's avatar
Ian Lynagh committed
935
    hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
936
       2 (dcolon <+> ppr ty)
chak's avatar
chak committed
937 938

instance Outputable ForeignImport where
939
  ppr (CImport  cconv safety header spec) =
chak's avatar
chak committed
940
    ppr cconv <+> ppr safety <+> 
941
    char '"' <> pprCEntity spec <> char '"'
chak's avatar
chak committed
942
    where
943 944 945 946
      pp_hdr = if nullFS header then empty else ftext header

      pprCEntity (CLabel lbl) = 
        ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
947
      pprCEntity (CFunction (StaticTarget lbl _)) = 
948
        ptext (sLit "static") <+> pp_hdr <+> ppr lbl