HsDecls.lhs 33.7 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5 6

HsDecls: Abstract syntax: global declarations
7

8
Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
sof's avatar
sof committed
9
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
10 11

\begin{code}
12
{-# OPTIONS -fno-warn-incomplete-patterns #-}
13 14 15
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
16
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 18
-- for details

19
module HsDecls (
20
	HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
21
	InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
22
	FamilyFlavour(..),
23
	RuleDecl(..), LRuleDecl, RuleBndr(..),
24
	DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
25
	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
chak's avatar
chak committed
26
	CImportSpec(..), FoType(..),
27 28
	ConDecl(..), ResType(..), ConDeclField(..), LConDecl,	
	HsConDeclDetails, hsConDeclArgTys,
29
	DocDecl(..), LDocDecl, docDeclDoc,
Ian Lynagh's avatar
Ian Lynagh committed
30
	WarnDecl(..),  LWarnDecl,
31
	HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
32
	tcdName, tyClDeclNames, tyClDeclTyVars,
33 34
	isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
	isFamInstDecl, 
35
	countTyClDecls,
36
	instDeclATs,
37
	collectRuleBndrSigTys, 
38
    ) where
39 40

-- friends:
41 42 43
import {-# SOURCE #-}	HsExpr( HsExpr, pprExpr )
	-- Because Expr imports Decls via HsBracket

44 45
import HsBinds
import HsPat
46
import HsTypes
47 48 49 50 51 52
import HsDoc
import NameSet
import CoreSyn
import {- Kind parts of -} Type
import BasicTypes
import ForeignCall
53 54

-- others:
55
import Class
56
import Outputable	
57 58
import Util
import SrcLoc
rrt's avatar
rrt committed
59
import FastString
60 61

import Data.Maybe       ( isJust )
62 63
\end{code}

64 65 66 67 68 69 70
%************************************************************************
%*									*
\subsection[HsDecl]{Declarations}
%*									*
%************************************************************************

\begin{code}
71 72
type LHsDecl id = Located (HsDecl id)

73 74 75
data HsDecl id
  = TyClD	(TyClDecl id)
  | InstD	(InstDecl  id)
76
  | DerivD      (DerivDecl id)
77
  | ValD	(HsBind id)
78
  | SigD	(Sig id)
79 80
  | DefD	(DefaultDecl id)
  | ForD        (ForeignDecl id)
Ian Lynagh's avatar
Ian Lynagh committed
81
  | WarningD	(WarnDecl id)
82
  | RuleD	(RuleDecl id)
83
  | SpliceD	(SpliceDecl id)
84 85
  | DocD	(DocDecl id)

86 87

-- NB: all top-level fixity decls are contained EITHER
88
-- EITHER SigDs
89 90 91 92 93 94 95 96 97 98
-- 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
99

100 101 102 103
-- A [HsDecl] is categorised into a HsGroup before being 
-- fed to the renamer.
data HsGroup id
  = HsGroup {
104
	hs_valds  :: HsValBinds id,
105 106
	hs_tyclds :: [LTyClDecl id],
	hs_instds :: [LInstDecl id],
107
        hs_derivds :: [LDerivDecl id],
108

109
	hs_fixds  :: [LFixitySig id],
110 111 112
		-- Snaffled out of both top-level fixity signatures,
		-- and those in class declarations

113 114
	hs_defds  :: [LDefaultDecl id],
	hs_fords  :: [LForeignDecl id],
Ian Lynagh's avatar
Ian Lynagh committed
115
	hs_warnds :: [LWarnDecl id],
116 117
	hs_ruleds :: [LRuleDecl id],

118
	hs_docs   :: [LDocDecl id]
119
  }
120

121 122 123 124
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

125
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
126
		       hs_fixds = [], hs_defds = [], hs_fords = [], 
Ian Lynagh's avatar
Ian Lynagh committed
127
		       hs_warnds = [], hs_ruleds = [],
128 129
		       hs_valds = error "emptyGroup hs_valds: Can't happen",
                       hs_docs = [] }
130 131 132 133 134 135 136

appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
appendGroups 
    HsGroup { 
	hs_valds  = val_groups1,
	hs_tyclds = tyclds1, 
	hs_instds = instds1,
137
        hs_derivds = derivds1,
138 139 140
	hs_fixds  = fixds1, 
	hs_defds  = defds1,
	hs_fords  = fords1, 
Ian Lynagh's avatar
Ian Lynagh committed
141
	hs_warnds = warnds1,
142 143
	hs_ruleds = rulds1,
  hs_docs   = docs1 }
144 145 146 147
    HsGroup { 
	hs_valds  = val_groups2,
	hs_tyclds = tyclds2, 
	hs_instds = instds2,
148
        hs_derivds = derivds2,
149 150 151
	hs_fixds  = fixds2, 
	hs_defds  = defds2,
	hs_fords  = fords2, 
Ian Lynagh's avatar
Ian Lynagh committed
152
	hs_warnds = warnds2,
153 154
	hs_ruleds = rulds2,
  hs_docs   = docs2 }
155 156
  = 
    HsGroup { 
157
	hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
158 159
	hs_tyclds = tyclds1 ++ tyclds2, 
	hs_instds = instds1 ++ instds2,
160
        hs_derivds = derivds1 ++ derivds2,
161 162 163
	hs_fixds  = fixds1 ++ fixds2, 
	hs_defds  = defds1 ++ defds2,
	hs_fords  = fords1 ++ fords2, 
Ian Lynagh's avatar
Ian Lynagh committed
164
	hs_warnds = warnds1 ++ warnds2,
165 166
	hs_ruleds = rulds1 ++ rulds2,
  hs_docs   = docs1  ++ docs2 }
167 168 169
\end{code}

\begin{code}
170
instance OutputableBndr name => Outputable (HsDecl name) where
171 172 173 174 175 176 177 178
    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
Ian Lynagh's avatar
Ian Lynagh committed
179
    ppr (WarningD wd)           = ppr wd
180 181
    ppr (SpliceD dd)            = ppr dd
    ppr (DocD doc)              = ppr doc
182 183 184 185 186

instance OutputableBndr name => Outputable (HsGroup name) where
    ppr (HsGroup { hs_valds  = val_decls,
		   hs_tyclds = tycl_decls,
		   hs_instds = inst_decls,
187
                   hs_derivds = deriv_decls,
188
		   hs_fixds  = fix_decls,
Ian Lynagh's avatar
Ian Lynagh committed
189
		   hs_warnds = deprec_decls,
190 191
		   hs_fords  = foreign_decls,
		   hs_defds  = default_decls,
192
		   hs_ruleds = rule_decls })
193 194 195 196
	= vcat [ppr_ds fix_decls, ppr_ds default_decls, 
		ppr_ds deprec_decls, ppr_ds rule_decls,
		ppr val_decls,
		ppr_ds tycl_decls, ppr_ds inst_decls,
197
                ppr_ds deriv_decls,
198
		ppr_ds foreign_decls]
199 200 201
	where
	  ppr_ds [] = empty
	  ppr_ds ds = text "" $$ vcat (map ppr ds)
202

203
data SpliceDecl id = SpliceDecl (Located (HsExpr id))	-- Top level splice
204 205

instance OutputableBndr name => Outputable (SpliceDecl name) where
Ian Lynagh's avatar
Ian Lynagh committed
206
   ppr (SpliceDecl e) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
207 208
\end{code}

209

210 211 212 213 214 215
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

216 217 218
		--------------------------------
			THE NAMING STORY
		--------------------------------
219

220 221
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
222 223 224

"Implicit" (or "system") binders
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
225 226 227 228 229 230 231 232 233
  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

234 235
All have occurrence names that are derived uniquely from their parent
declaration.
236 237 238 239 240 241 242 243 244

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
245 246 247 248 249
   (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
250

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

254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
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:
269

270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
 - 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

331
  - The CoreTidy phase externalises the name, and ensures the occurrence name is
332 333 334 335 336 337 338 339 340 341 342 343
    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.
344

345 346
  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
    suck in the dfun binding
347 348


349
\begin{code}
350 351
-- Representation of indexed types
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 353 354
-- 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'.
355 356 357
--
-- Indexed types are represented by 'TyData' and 'TySynonym' using the field
-- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
358 359 360 361 362
--
--   * 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.
--
363
--   * If it is 'Just pats', we have the definition of an indexed type.  Then,
364
--     'pats' are type patterns for the type-indexes of the type constructor
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
365
--     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
366 367
--     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
--     *not* 'length tcdVars'.
368 369 370
--
-- In both cases, 'tcdVars' collects all variables we need to quantify over.

371 372
type LTyClDecl name = Located (TyClDecl name)

373
data TyClDecl name
374 375 376 377
  = ForeignType { 
		tcdLName    :: Located name,
		tcdExtName  :: Maybe FastString,
		tcdFoType   :: FoType
378 379
    }

380
	-- type/data/newtype family T :: *->*
381 382 383 384 385
  | TyFamily {  tcdFlavour:: FamilyFlavour,	        -- type, new, or data
		tcdLName  :: Located name,	        -- type constructor
		tcdTyVars :: [LHsTyVarBndr name],	-- type variables
		tcdKind   :: Maybe Kind			-- result kind
    }
386

387 388 389
	-- Declares a data type or newtype, giving its construcors
	-- 	data/newtype T a = <constrs>
	--	data/newtype instance T [a] = <constrs>
390
  | TyData {	tcdND     :: NewOrData,
391 392
		tcdCtxt   :: LHsContext name,	 	-- Context
		tcdLName  :: Located name,	 	-- Type constructor
393

394
		tcdTyVars :: [LHsTyVarBndr name], 	-- Type variables
395
			
396
		tcdTyPats :: Maybe [LHsType name],	-- Type patterns
397 398 399 400 401
			-- Just [t1..tn] for data instance T t1..tn = ...
			--	in this case tcdTyVars = fv( tcdTyPats )
			-- Nothing for everything else

		tcdKindSig:: Maybe Kind,		-- Optional kind sig 
402 403
			-- (Just k) for a GADT-style 'data', or 'data
			-- instance' decl with explicit kind sig
404

405
		tcdCons	  :: [LConDecl name],	 	-- Data constructors
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
406 407 408 409
			-- For data T a = T1 | T2 a          
                        --   the LConDecls all have ResTyH98
			-- For data T a where { T1 :: T a }  
                        --   the LConDecls all have ResTyGADT
410

411
		tcdDerivs :: Maybe [LHsType name]
412 413
			-- Derivings; Nothing => not specified
			-- 	      Just [] => derive exactly what is asked
414 415 416 417
			-- These "types" must be of form
			--	forall ab. C ty1 ty2
			-- Typically the foralls and ty args are empty, but they
			-- are non-empty for the newtype-deriving case
418
    }
419

420 421
  | TySynonym {	tcdLName  :: Located name,	        -- type constructor
		tcdTyVars :: [LHsTyVarBndr name],	-- type variables
422
		tcdTyPats :: Maybe [LHsType name],	-- Type patterns
423 424 425
			-- See comments for tcdTyPats in TyData
			-- 'Nothing' => vanilla type synonym

426
		tcdSynRhs :: LHsType name	        -- synonym expansion
427 428
    }

429 430 431 432 433
  | 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
434
		tcdMeths   :: LHsBinds name,		-- Default methods
435
		tcdATs	   :: [LTyClDecl name],		-- Associated types; ie
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
436 437 438
							--   only 'TyFamily' and
							--   'TySynonym'; the
                                                        --   latter for defaults
439
		tcdDocs    :: [LDocDecl name]		-- Haddock docs
440
    }
441 442

data NewOrData
443 444 445 446 447 448
  = NewType			-- "newtype Blah ..."
  | DataType			-- "data Blah ..."
  deriving( Eq )		-- Needed because Demand derives Eq

data FamilyFlavour
  = TypeFamily			-- "type family ..."
449
  | DataFamily	                -- "data family ..."
450 451 452 453 454
\end{code}

Simple classifiers

\begin{code}
455
isDataDecl, isTypeDecl, isSynDecl, isClassDecl, isFamilyDecl, isFamInstDecl :: 
456 457
  TyClDecl name -> Bool

458 459 460
-- data/newtype or data/newtype instance declaration
isDataDecl (TyData {}) = True
isDataDecl _other      = False
461

462 463 464
-- type or type instance declaration
isTypeDecl (TySynonym {}) = True
isTypeDecl _other	  = False
465

466 467 468
-- vanilla Haskell type synonym (ie, not a type instance)
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
isSynDecl _other	                    = False
469

470
-- type class
471
isClassDecl (ClassDecl {}) = True
472
isClassDecl _              = False
473

474 475 476 477 478 479 480 481 482
-- type family declaration
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other        = False

-- family instance (types, newtypes, and data types)
isFamInstDecl tydecl
   | isTypeDecl tydecl
     || isDataDecl tydecl = isJust (tcdTyPats tydecl)
   | otherwise	          = False
483 484 485
\end{code}

Dealing with names
486

487
\begin{code}
488 489
tcdName :: TyClDecl name -> name
tcdName decl = unLoc (tcdLName decl)
490

491
tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
492
-- Returns all the *binding* names of the decl, along with their SrcLocs
493 494 495 496
-- The first one is guaranteed to be the name of the decl
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names

497
tyClDeclNames (TyFamily    {tcdLName = name})    = [name]
498
tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
499
tyClDeclNames (ForeignType {tcdLName = name})    = [name]
500

501 502 503
tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
  = cls_name : 
    concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
504

505 506
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
  = tc_name : conDeclsNames (map unLoc cons)
507

508
tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
509
tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
510 511 512 513
tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ForeignType {})		       = []
514 515 516
\end{code}

\begin{code}
517
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
518
	-- class, synonym decls, data, newtype, family decls, family instances
519
countTyClDecls decls 
520 521 522 523 524 525
 = (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
526
 where
527 528
   isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
   isDataTy _                                             = False
sof's avatar
sof committed
529
   
530 531
   isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
   isNewTy _                                            = False
532 533 534
\end{code}

\begin{code}
535 536
instance OutputableBndr name
	      => Outputable (TyClDecl name) where
537

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

541 542 543
    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
		   tcdTyVars = tyvars, tcdKind = mb_kind})
      = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
544
        where
545
	  pp_flavour = case flavour of
Ian Lynagh's avatar
Ian Lynagh committed
546 547
		         TypeFamily -> ptext (sLit "type family")
			 DataFamily -> ptext (sLit "data family")
548 549 550 551

          pp_kind = case mb_kind of
		      Nothing   -> empty
		      Just kind -> dcolon <+> pprKind kind
552 553 554

    ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
		    tcdSynRhs = mono_ty})
Ian Lynagh's avatar
Ian Lynagh committed
555 556
      = hang (ptext (sLit "type") <+> 
	      (if isJust typats then ptext (sLit "instance") else empty) <+>
557
	      pp_decl_head [] ltycon tyvars typats <+> 
558
	      equals)
559
	     4 (ppr mono_ty)
560

561
    ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
562 563
		 tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
		 tcdCons = condecls, tcdDerivs = derivings})
564 565
      = pp_tydecl (null condecls && isJust mb_sig) 
                  (ppr new_or_data <+> 
Ian Lynagh's avatar
Ian Lynagh committed
566
		   (if isJust typats then ptext (sLit "instance") else empty) <+>
567 568
		   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
		   ppr_sig mb_sig)
569
		  (pp_condecls condecls)
570
		  derivings
571 572 573
      where
	ppr_sig Nothing = empty
	ppr_sig (Just kind) = dcolon <+> pprKind kind
574

575 576 577 578
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
		    tcdFDs = fds, 
		    tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
      | null sigs && null ats  -- No "where" part
579 580 581
      = top_matter

      | otherwise	-- Laid out
Ian Lynagh's avatar
Ian Lynagh committed
582
      = sep [hsep [top_matter, ptext (sLit "where {")],
583 584 585 586
	     nest 4 (sep [ sep (map ppr_semi ats)
			 , sep (map ppr_semi sigs)
			 , pprLHsBinds methods
			 , char '}'])]
587
      where
Ian Lynagh's avatar
Ian Lynagh committed
588
        top_matter    =     ptext (sLit "class") 
589 590 591
		        <+> pp_decl_head (unLoc context) lclas tyvars Nothing
		        <+> pprFundeps (map unLoc fds)
	ppr_semi decl = ppr decl <> semi
592

593 594 595 596
pp_decl_head :: OutputableBndr name
   => HsContext name
   -> Located name
   -> [LHsTyVarBndr name]
597
   -> Maybe [LHsType name]
598
   -> SDoc
599
pp_decl_head context thing tyvars Nothing	-- no explicit type patterns
600
  = hsep [pprHsContext context, ppr thing, interppSP tyvars]
601 602 603 604
pp_decl_head context thing _      (Just typats) -- explicit type patterns
  = hsep [ pprHsContext context, ppr thing
	 , hsep (map (pprParendHsType.unLoc) typats)]

605
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
606
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
Ian Lynagh's avatar
Ian Lynagh committed
607
  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
608
pp_condecls cs 			  -- In H98 syntax
Ian Lynagh's avatar
Ian Lynagh committed
609
  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
610

611 612
pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
pp_tydecl True  pp_head _ _
613 614
  = pp_head
pp_tydecl False pp_head pp_decl_rhs derivings
sof's avatar
sof committed
615
  = hang pp_head 4 (sep [
616 617 618
      pp_decl_rhs,
      case derivings of
        Nothing -> empty
Ian Lynagh's avatar
Ian Lynagh committed
619
	Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
620
    ])
621 622

instance Outputable NewOrData where
Ian Lynagh's avatar
Ian Lynagh committed
623 624
  ppr NewType  = ptext (sLit "newtype")
  ppr DataType = ptext (sLit "data")
625 626 627 628 629 630 631 632 633 634
\end{code}


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

\begin{code}
635 636
type LConDecl name = Located (ConDecl name)

637 638 639 640 641 642 643 644 645 646 647 648
-- 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

649
data ConDecl name
650 651 652 653 654 655 656 657 658 659 660 661
  = ConDecl
    { con_name      :: Located name	    -- Constructor name; this is used for the
                                            -- DataCon itself, and for the user-callable wrapper Id

    , con_explicit  :: HsExplicitForAll     -- Is there an user-written forall? (cf. HStypes.HsForAllTy)

    , con_qvars     :: [LHsTyVarBndr name]  -- ResTyH98: the constructor's existential type variables
					    -- ResTyGADT:    all the constructor's quantified type variables

    , con_cxt       :: LHsContext name      -- The context.  This *does not* include the
					    -- "stupid theta" which lives only in the TyData decl

662
    , con_details   :: HsConDeclDetails name	-- The main payload
663 664

    , con_res       :: ResType name         -- Result type of the constructor
665 666

    , con_doc       :: Maybe (LHsDoc name)  -- A possible Haddock comment
667 668
    }

669 670 671 672 673 674 675 676 677 678 679 680
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

data ConDeclField name	-- Record fields have Haddoc docs on them
  = ConDeclField { cd_fld_name :: Located name,
		   cd_fld_type :: LBangType name, 
		   cd_fld_doc  :: Maybe (LHsDoc name) }

681 682 683 684
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
685 686 687
\end{code}

\begin{code}
688
conDeclsNames :: (Eq name) => [ConDecl name] -> [Located name]
689 690 691 692
  -- See tyClDeclNames for what this does
  -- The function is boringly complicated because of the records
  -- And since we only have equality, we have to be a little careful
conDeclsNames cons
693
  = snd (foldl do_one ([], []) cons)
694
  where
695
    do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
696
	= (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
697
	where
698 699
	  new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
			       (map cd_fld_name flds)
700

701 702
    do_one (flds_seen, acc) c
	= (flds_seen, (con_name c):acc)
703
\end{code}
704
  
705 706

\begin{code}
707
instance (OutputableBndr name) => Outputable (ConDecl name) where
708 709
    ppr = pprConDecl

710
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
711 712
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
sof's avatar
sof committed
713
  where
714
    ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
715 716 717
    ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
    ppr_details con (RecCon fields)  = ppr con <+> ppr_fields fields

718
pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
719 720
  = ppr con <+> dcolon <+> 
    sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
721 722
  where
    mk_fun_ty a b = noLoc (HsFunTy a b)
sof's avatar
sof committed
723

724 725 726
pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
  = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
727
pprConDecl (ConDecl con _expl _tvs _cxt (InfixCon _ _) (ResTyGADT _res_ty) _)
728 729 730 731
  = pprPanic "pprConDecl" (ppr con)
	-- In GADT syntax we don't allow infix constructors


732
ppr_fields :: OutputableBndr name => [ConDeclField name] -> SDoc
733 734 735 736 737
ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields)))
  where
    ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, 
			    cd_fld_doc = doc })
  	= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
738 739 740 741
\end{code}

%************************************************************************
%*									*
sof's avatar
sof committed
742
\subsection[InstDecl]{An instance declaration
743 744 745 746
%*									*
%************************************************************************

\begin{code}
747 748
type LInstDecl name = Located (InstDecl name)

749
data InstDecl name
750
  = InstDecl	(LHsType name)	-- Context => Class Instance-type
751 752
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.
753
		(LHsBinds name)
754
		[LSig name]	-- User-supplied pragmatic info
755 756
		[LTyClDecl name]-- Associated types (ie, 'TyData' and
				-- 'TySynonym' only)
757

758
instance (OutputableBndr name) => Outputable (InstDecl name) where
759

760
    ppr (InstDecl inst_ty binds uprags ats)
Ian Lynagh's avatar
Ian Lynagh committed
761
      = vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")]
762 763 764
             , nest 4 $ vcat (map ppr ats)
 	     , nest 4 $ vcat (map ppr uprags)
	     , nest 4 $ pprLHsBinds binds ]
765 766 767 768 769

-- Extract the declarations of associated types from an instance
--
instDeclATs :: InstDecl name -> [LTyClDecl name]
instDeclATs (InstDecl _ _ _ ats) = ats
770 771
\end{code}

772 773 774 775 776 777 778 779 780
%************************************************************************
%*									*
\subsection[DerivDecl]{A stand-alone instance deriving declaration
%*									*
%************************************************************************

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

781
data DerivDecl name = DerivDecl (LHsType name)
782 783

instance (OutputableBndr name) => Outputable (DerivDecl name) where
784
    ppr (DerivDecl ty) 
Ian Lynagh's avatar
Ian Lynagh committed
785
        = hsep [ptext (sLit "derived instance"), ppr ty]
786 787
\end{code}

788 789 790 791 792 793 794 795 796 797 798
%************************************************************************
%*									*
\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}
799 800
type LDefaultDecl name = Located (DefaultDecl name)

801
data DefaultDecl name
802
  = DefaultDecl	[LHsType name]
803

804
instance (OutputableBndr name)
805 806
	      => Outputable (DefaultDecl name) where

807
    ppr (DefaultDecl tys)
Ian Lynagh's avatar
Ian Lynagh committed
808
      = ptext (sLit "default") <+> parens (interpp'SP tys)
809
\end{code}
810

sof's avatar
sof committed
811 812 813 814 815 816 817
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
chak's avatar
chak committed
818 819 820 821

-- foreign declarations are distinguished as to whether they define or use a
-- Haskell name
--
822
--  * the Boolean value indicates whether the pre-standard deprecated syntax
chak's avatar
chak committed
823 824
--   has been used
--
825 826
type LForeignDecl name = Located (ForeignDecl name)

827
data ForeignDecl name
Simon Marlow's avatar
Simon Marlow committed
828 829
  = ForeignImport (Located name) (LHsType name) ForeignImport  -- defines name
  | ForeignExport (Located name) (LHsType name) ForeignExport  -- uses name
830

Simon Marlow's avatar
Simon Marlow committed
831
-- Specification Of an imported external entity in dependence on the calling
chak's avatar
chak committed
832 833 834 835
-- convention 
--
data ForeignImport = -- import of a C entity
		     --
836
                     --  * the two strings specifying a header file or library
chak's avatar
chak committed
837 838 839 840 841
                     --   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)
		     --
842
		     --  * the calling convention is irrelevant for code
chak's avatar
chak committed
843 844 845
		     --   generation in the case of `CLabel', but is needed
		     --   for pretty printing 
		     --
846
		     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
chak's avatar
chak committed
847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863
		     --
		     CImport  CCallConv	      -- ccall or stdcall
			      Safety	      -- safe or unsafe
			      FastString      -- name of C header
			      FastString      -- name of library object
			      CImportSpec     -- details of the C entity

                     -- import of a .NET function
		     --
		   | DNImport DNCallSpec

-- 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.)
864

chak's avatar
chak committed
865 866 867 868 869
-- specification of an externally exported entity in dependence on the calling
-- convention
--
data ForeignExport = CExport  CExportSpec    -- contains the calling convention
		   | DNExport		     -- presently unused
870

chak's avatar
chak committed
871 872
-- abstract type imported from .NET
--
873
data FoType = DNType 		-- In due course we'll add subtype stuff
chak's avatar
chak committed
874 875 876 877 878
	    deriving (Eq)	-- Used for equality instance for TyClDecl


-- pretty printing of foreign declarations
--
879

880
instance OutputableBndr name => Outputable (ForeignDecl name) where
Simon Marlow's avatar
Simon Marlow committed
881
  ppr (ForeignImport n ty fimport) =
Ian Lynagh's avatar
Ian Lynagh committed
882
    hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
883
       2 (dcolon <+> ppr ty)
Simon Marlow's avatar
Simon Marlow committed
884
  ppr (ForeignExport n ty fexport) =
Ian Lynagh's avatar
Ian Lynagh committed
885
    hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
886
       2 (dcolon <+> ppr ty)
chak's avatar
chak committed
887 888 889

instance Outputable ForeignImport where
  ppr (DNImport			        spec) = 
Ian Lynagh's avatar
Ian Lynagh committed
890
    ptext (sLit "dotnet") <+> ppr spec
chak's avatar
chak committed
891 892 893 894 895
  ppr (CImport  cconv safety header lib spec) =
    ppr cconv <+> ppr safety <+> 
    char '"' <> pprCEntity header lib spec <> char '"'
    where
      pprCEntity header lib (CLabel lbl) = 
Ian Lynagh's avatar
Ian Lynagh committed
896
        ptext (sLit "static") <+> ftext header <+> char '&' <>
chak's avatar
chak committed
897 898
	pprLib lib <> ppr lbl
      pprCEntity header lib (CFunction (StaticTarget lbl)) = 
Ian Lynagh's avatar
Ian Lynagh committed
899
        ptext (sLit "static") <+> ftext header <+> char '&' <>
chak's avatar
chak committed
900
	pprLib lib <> ppr lbl
901
      pprCEntity _      _   (CFunction (DynamicTarget)) =
Ian Lynagh's avatar
Ian Lynagh committed
902 903
        ptext (sLit "dynamic")
      pprCEntity _      _   (CWrapper) = ptext (sLit "wrapper")
chak's avatar
chak committed
904
      --
905 906
      pprLib lib | nullFS lib = empty
		 | otherwise  = char '[' <> ppr lib <> char ']'
chak's avatar
chak committed
907 908 909 910 911

instance Outputable ForeignExport where
  ppr (CExport  (CExportStatic lbl cconv)) = 
    ppr cconv <+> char '"' <> ppr lbl <> char '"'
  ppr (DNExport                          ) = 
Ian Lynagh's avatar
Ian Lynagh committed
912
    ptext (sLit "dotnet") <+> ptext (sLit "\"<unused>\"")
913 914

instance Outputable FoType where
Ian Lynagh's avatar
Ian Lynagh committed
915
  ppr DNType = ptext (sLit "type dotnet")
sof's avatar
sof committed
916 917
\end{code}

918

919 920
%************************************************************************
%*									*
921
\subsection{Transformation rules}
922 923 924 925
%*									*
%************************************************************************

\begin{code}
926 927
type LRuleDecl name = Located (RuleDecl name)

928
data RuleDecl name
929
  = HsRule			-- Source rule
930 931
	RuleName		-- Rule name
	Activation
932
	[RuleBndr name]		-- Forall'd vars; after typechecking this includes tyvars
933
	(Located (HsExpr name))	-- LHS
934
        NameSet                 -- Free-vars from the LHS
935
	(Located (HsExpr name))	-- RHS
936
        NameSet                 -- Free-vars from the RHS
937 938

data RuleBndr name
939 940
  = RuleBndr (Located name)
  | RuleBndrSig (Located name) (LHsType name)
941

942
collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
943 944
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]

945
instance OutputableBndr name => Outputable (RuleDecl name) where
946
  ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)