HsDecls.lhs 46.8 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
  -- * Toplevel declarations
  HsDecl(..), LHsDecl,
  -- ** Class or type declarations
dreixel's avatar
dreixel committed
17
  TyClDecl(..), LTyClDecl, TyClGroup,
18
  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
  lvectDeclName, lvectInstDecl,
32 33 34 35 36 37
  -- ** @default@ declarations
  DefaultDecl(..), LDefaultDecl,
  -- ** Top-level template haskell splice
  SpliceDecl(..),
  -- ** Foreign function interface declarations
  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
38
  noForeignImportCoercionYet, noForeignExportCoercionYet,
39
  CImportSpec(..),
40
  -- ** Data-constructor declarations
41
  ConDecl(..), LConDecl, ResType(..), 
42
  HsConDeclDetails, hsConDeclArgTys, 
43 44 45 46
  -- ** Document comments
  DocDecl(..), LDocDecl, docDeclDoc,
  -- ** Deprecations
  WarnDecl(..),  LWarnDecl,
47 48 49
  -- ** Annotations
  AnnDecl(..), LAnnDecl, 
  AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
50 51

  -- * Grouping
52 53
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
    ) where
54 55

-- friends:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
56 57
import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, pprExpr )
        -- Because Expr imports Decls via HsBracket
58

59 60
import HsBinds
import HsPat
61
import HsTypes
62
import HsDoc
63
import TyCon
64
import NameSet
65
import Name
66
import BasicTypes
67
import Coercion
68
import ForeignCall
69 70

-- others:
71
import InstEnv
72
import Class
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
73
import Outputable       
74 75
import Util
import SrcLoc
rrt's avatar
rrt committed
76
import FastString
77

78
import Bag
79
import Control.Monad    ( liftM )
80
import Data.Data        hiding (TyCon)
81
import Data.Maybe       ( isJust )
82 83
\end{code}

84
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
85
%*                                                                      *
86
\subsection[HsDecl]{Declarations}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
87
%*                                                                      *
88 89 90
%************************************************************************

\begin{code}
91 92
type LHsDecl id = Located (HsDecl id)

93
-- | A Haskell Declaration
94
data HsDecl id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
95 96
  = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
  | InstD       (InstDecl  id)    -- ^ An instance declaration.
97
  | DerivD      (DerivDecl id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
98 99 100
  | ValD        (HsBind id)
  | SigD        (Sig id)
  | DefD        (DefaultDecl id)
101
  | ForD        (ForeignDecl id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
102 103 104 105 106 107 108
  | WarningD    (WarnDecl id)
  | AnnD        (AnnDecl id)
  | RuleD       (RuleDecl id)
  | VectD       (VectDecl id)
  | SpliceD     (SpliceDecl id)
  | DocD        (DocDecl)
  | QuasiQuoteD (HsQuasiQuote id)
109
  deriving (Data, Typeable)
110

111 112

-- NB: all top-level fixity decls are contained EITHER
113
-- EITHER SigDs
114 115 116
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
117 118 119 120 121
--      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
122 123
--
-- The latter is for class methods only
124

125
-- | A 'HsDecl' is categorised into a 'HsGroup' before being
126 127 128
-- fed to the renamer.
data HsGroup id
  = HsGroup {
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
129
        hs_valds  :: HsValBinds id,
130

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
131 132 133 134
        hs_tyclds :: [[LTyClDecl id]],  
                -- A list of mutually-recursive groups
                -- Parser generates a singleton list;
                -- renamer does dependency analysis
135

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
136
        hs_instds :: [LInstDecl id],
137
        hs_derivds :: [LDerivDecl id],
138

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
139 140 141
        hs_fixds  :: [LFixitySig id],
                -- Snaffled out of both top-level fixity signatures,
                -- and those in class declarations
142

143 144 145 146 147 148
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
        hs_warnds :: [LWarnDecl id],
        hs_annds  :: [LAnnDecl id],
        hs_ruleds :: [LRuleDecl id],
        hs_vects  :: [LVectDecl id],
149

150
        hs_docs   :: [LDocDecl]
151
  } deriving (Data, Typeable)
152

153 154 155 156
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

157
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
158 159 160
                       hs_fixds = [], hs_defds = [], hs_annds = [],
                       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
                       hs_valds = error "emptyGroup hs_valds: Can't happen",
161
                       hs_docs = [] }
162 163 164 165

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

\begin{code}
208
instance OutputableBndr name => Outputable (HsDecl name) where
209 210 211 212 213 214 215 216
    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
217
    ppr (VectD vect)            = ppr vect
Ian Lynagh's avatar
Ian Lynagh committed
218
    ppr (WarningD wd)           = ppr wd
219
    ppr (AnnD ad)               = ppr ad
220 221
    ppr (SpliceD dd)            = ppr dd
    ppr (DocD doc)              = ppr doc
222
    ppr (QuasiQuoteD qq)        = ppr qq
223 224 225

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

          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
254
          -- Concatenate vertically with white-space between non-blanks
255 256 257
          vcat_mb _    []             = empty
          vcat_mb gap (Nothing : ds) = vcat_mb gap ds
          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
258

259
data SpliceDecl id 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
260
  = SpliceDecl                  -- Top level splice
261
        (Located (HsExpr id))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
262 263
        HsExplicitFlag          -- Explicit <=> $(f x y)
                                -- Implicit <=> f x y,  i.e. a naked top level expression
264
    deriving (Data, Typeable)
265 266

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

270

271
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
272
%*                                                                      *
273
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
274
%*                                                                      *
275 276
%************************************************************************

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
277 278 279
                --------------------------------
                        THE NAMING STORY
                --------------------------------
280

281 282
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
283 284 285

"Implicit" (or "system") binders
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
286
  Each data type decl defines 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
287 288
        a worker name for each constructor
        to-T and from-T convertors
289
  Each class decl defines
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
290 291 292 293
        a tycon for the class
        a data constructor for that tycon
        the worker for that constructor
        a selector for each superclass
294

295 296
All have occurrence names that are derived uniquely from their parent
declaration.
297 298 299 300 301 302 303 304 305

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
306 307 308 309 310
   (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
311

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

315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
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:
330

331 332 333 334 335 336 337
 - 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:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
338 339 340 341
        class Foo a where
          op1 :: <type>
          op2 :: <type>
          op1 = ...
342 343 344 345 346 347 348
   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:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
349 350 351
        class Foo a where
          op1 = :: <type>       -- NB the '='
          op2   :: <type>
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371
    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:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
372 373
        instance {Eq Int} = dEqInt
        dEqInt :: {Eq Int} <pragma info>
374 375 376 377 378 379 380 381 382 383 384 385 386 387

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.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
388 389
        instance Foo [Int]  where ...
        instance Foo [Bool] where ...
390 391
    These might both be dFooList

392
  - The CoreTidy phase externalises the name, and ensures the occurrence name is
393 394 395 396 397 398 399 400 401 402 403 404
    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.
405

406 407
  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
    suck in the dfun binding
408 409


410
\begin{code}
411 412
-- Representation of indexed types
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
413 414 415
-- 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'.
416 417 418
--
-- Indexed types are represented by 'TyData' and 'TySynonym' using the field
-- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
419 420 421 422 423
--
--   * 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.
--
424
--   * If it is 'Just pats', we have the definition of an indexed type.  Then,
425
--     'pats' are type patterns for the type-indexes of the type constructor
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
426
--     and 'tcdTyVars' are the variables in those patterns.  Hence, the arity of
427 428
--     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
--     *not* 'length tcdVars'.
429 430 431
--
-- In both cases, 'tcdVars' collects all variables we need to quantify over.

432
type LTyClDecl name = Located (TyClDecl name)
dreixel's avatar
dreixel committed
433 434
type TyClGroup name = [LTyClDecl name]  -- this is used in TcTyClsDecls to represent
                                        -- strongly connected components of decls
435

436
-- | A type or class declaration.
437
data TyClDecl name
438
  = ForeignType { 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
439 440
                tcdLName    :: Located name,
                tcdExtName  :: Maybe FastString
441 442
    }

443

444
  | -- | @type/data family T :: *->*@
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
445 446 447
    TyFamily {  tcdFlavour:: FamilyFlavour,             -- type or data
                tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
dreixel's avatar
dreixel committed
448
                tcdKind   :: Maybe (LHsKind name)       -- result kind
449
    }
450

451

452 453
  | -- | Declares a data type or newtype, giving its construcors
    -- @
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
454 455
    --  data/newtype T a = <constrs>
    --  data/newtype instance T [a] = <constrs>
456
    -- @
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
457 458 459
    TyData {    tcdND     :: NewOrData,
                tcdCtxt   :: LHsContext name,           -- ^ Context
                tcdLName  :: Located name,              -- ^ Type constructor
460

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
461 462
                tcdTyVars :: [LHsTyVarBndr name],       -- ^ Type variables
                tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
463
                  -- See Note [tcdTyVars and tcdTyPats] 
464

dreixel's avatar
dreixel committed
465
                tcdKindSig:: Maybe (LHsKind name),
466 467
                        -- ^ Optional kind signature.
                        --
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
468 469
                        -- @(Just k)@ for a GADT-style @data@, or @data
                        -- instance@ decl with explicit kind sig
470

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
471
                tcdCons   :: [LConDecl name],
472 473
                        -- ^ Data constructors
                        --
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
474
                        -- For @data T a = T1 | T2 a@
475
                        --   the 'LConDecl's all have 'ResTyH98'.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
476
                        -- For @data T a where { T1 :: T a }@
477
                        --   the 'LConDecls' all have 'ResTyGADT'.
478

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
491 492 493
  | TySynonym { tcdLName  :: Located name,              -- ^ type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- ^ type variables
                tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
494
                  -- See Note [tcdTyVars and tcdTyPats] 
495

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
496
                tcdSynRhs :: LHsType name               -- ^ synonym expansion
497 498
    }

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
499 500 501 502 503 504 505 506
  | 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
                                                        --   only 'TyFamily'
507 508
                tcdATDefs  :: [LTyClDecl name],         -- ^ Associated type defaults; ie
                                                        --   only 'TySynonym'
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
509
                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
510
    }
511
  deriving (Data, Typeable)
512 513

data NewOrData
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
514 515 516
  = NewType                     -- ^ @newtype Blah ...@
  | DataType                    -- ^ @data Blah ...@
  deriving( Eq, Data, Typeable )                -- Needed because Demand derives Eq
517 518

data FamilyFlavour
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
519 520
  = TypeFamily                  -- ^ @type family ...@
  | DataFamily                  -- ^ @data family ...@
521
  deriving (Data, Typeable)
522 523
\end{code}

524 525 526 527 528 529 530 531 532 533 534 535 536 537 538
Note [tcdTyVars and tcdTyPats] 
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use TyData and TySynonym both for vanilla data/type declarations
     type T a = Int
AND for data/type family instance declarations
     type instance F [a] = (a,Int)

tcdTyPats = Nothing
   This is a vanilla data type or type synonym
   tcdTyVars are the quantified type variables

tcdTyPats = Just tys
   This is a data/type family instance declaration
   tcdTyVars are fv(tys)

dreixel's avatar
dreixel committed
539 540 541 542 543 544 545 546 547 548 549 550
   Eg   class C s t where
          type F t p :: *
        instance C w (a,b) where
          type F (a,b) x = x->a
   The tcdTyVars of the F decl are {a,b,x}, even though the F decl
   is nested inside the 'instance' decl. 

   However after the renamer, the uniques will match up:
        instance C w7 (a8,b9) where
          type F (a8,b9) x10 = x10->a8
   so that we can compare the type patter in the 'instance' decl and
   in the associated 'type' decl
551 552

------------------------------
553 554 555
Simple classifiers

\begin{code}
556 557 558
-- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@
-- declaration.
isDataDecl :: TyClDecl name -> Bool
559 560
isDataDecl (TyData {}) = True
isDataDecl _other      = False
561

562 563
-- | type or type instance declaration
isTypeDecl :: TyClDecl name -> Bool
564
isTypeDecl (TySynonym {}) = True
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
565
isTypeDecl _other         = False
566

567 568
-- | vanilla Haskell type synonym (ie, not a type instance)
isSynDecl :: TyClDecl name -> Bool
569
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
570
isSynDecl _other                            = False
571

572 573
-- | type class
isClassDecl :: TyClDecl name -> Bool
574
isClassDecl (ClassDecl {}) = True
575
isClassDecl _              = False
576

577 578
-- | type family declaration
isFamilyDecl :: TyClDecl name -> Bool
579 580 581
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other        = False

582 583
-- | family instance (types, newtypes, and data types)
isFamInstDecl :: TyClDecl name -> Bool
584 585 586
isFamInstDecl tydecl
   | isTypeDecl tydecl
     || isDataDecl tydecl = isJust (tcdTyPats tydecl)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
587
   | otherwise            = False
588 589 590
\end{code}

Dealing with names
591

592
\begin{code}
593 594
tcdName :: TyClDecl name -> name
tcdName decl = unLoc (tcdLName decl)
595

596
tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
597
tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
598 599 600
tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
601
tyClDeclTyVars (ForeignType {})                = []
602 603 604
\end{code}

\begin{code}
605
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
606
        -- class, synonym decls, data, newtype, family decls, family instances
607
countTyClDecls decls 
608 609 610 611 612 613
 = (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
614
 where
615 616
   isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
   isDataTy _                                             = False
sof's avatar
sof committed
617
   
618 619
   isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
   isNewTy _                                            = False
620 621 622
\end{code}

\begin{code}
623
instance OutputableBndr name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
624
              => Outputable (TyClDecl name) where
625

626
    ppr (ForeignType {tcdLName = ltycon})
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
627
        = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
628

629
    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
630
                   tcdTyVars = tyvars, tcdKind = mb_kind})
631
      = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
632
        where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
633 634 635
          pp_flavour = case flavour of
                         TypeFamily -> ptext (sLit "type family")
                         DataFamily -> ptext (sLit "data family")
636 637

          pp_kind = case mb_kind of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
638
                      Nothing   -> empty
dreixel's avatar
dreixel committed
639
                      Just kind -> dcolon <+> ppr kind
640 641

    ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
642
                    tcdSynRhs = mono_ty})
Ian Lynagh's avatar
Ian Lynagh committed
643
      = hang (ptext (sLit "type") <+> 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
644 645 646 647
              (if isJust typats then ptext (sLit "instance") else empty) <+>
              pp_decl_head [] ltycon tyvars typats <+> 
              equals)
             4 (ppr mono_ty)
648

649
    ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
650 651
                 tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
                 tcdCons = condecls, tcdDerivs = derivings})
652 653
      = pp_tydecl (null condecls && isJust mb_sig) 
                  (ppr new_or_data <+> 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
654 655 656 657 658
                   (if isJust typats then ptext (sLit "instance") else empty) <+>
                   pp_decl_head (unLoc context) ltycon tyvars typats <+> 
                   ppr_sigx mb_sig)
                  (pp_condecls condecls)
                  derivings
659
      where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
660
        ppr_sigx Nothing     = empty
dreixel's avatar
dreixel committed
661
        ppr_sigx (Just kind) = dcolon <+> ppr kind
662

663
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
664
                    tcdFDs  = fds,
665 666 667
                    tcdSigs = sigs, tcdMeths = methods,
                    tcdATs = ats, tcdATDefs = at_defs})
      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
668 669
      = top_matter

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
670
      | otherwise       -- Laid out
671
      = vcat [ top_matter <+> ptext (sLit "where")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
672
             , nest 2 $ pprDeclList (map ppr ats ++
673
                                     map ppr at_defs ++
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
674
                                     pprLHsBindsForUser methods sigs) ]
675
      where
676
        top_matter = ptext (sLit "class") 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
677 678
                     <+> pp_decl_head (unLoc context) lclas tyvars Nothing
                     <+> pprFundeps (map unLoc fds)
679

680 681 682 683
pp_decl_head :: OutputableBndr name
   => HsContext name
   -> Located name
   -> [LHsTyVarBndr name]
684
   -> Maybe [LHsType name]
685
   -> SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
686
pp_decl_head context thing tyvars Nothing       -- no explicit type patterns
687
  = hsep [pprHsContext context, ppr thing, interppSP tyvars]
688 689
pp_decl_head context thing _      (Just typats) -- explicit type patterns
  = hsep [ pprHsContext context, ppr thing
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
690
         , hsep (map (pprParendHsType.unLoc) typats)]
691

692
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
693
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
Ian Lynagh's avatar
Ian Lynagh committed
694
  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
695
pp_condecls cs                    -- In H98 syntax
Ian Lynagh's avatar
Ian Lynagh committed
696
  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
697

698 699
pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
pp_tydecl True  pp_head _ _
700 701
  = pp_head
pp_tydecl False pp_head pp_decl_rhs derivings
sof's avatar
sof committed
702
  = hang pp_head 4 (sep [
703 704 705
      pp_decl_rhs,
      case derivings of
        Nothing -> empty
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
706
        Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
707
    ])
708 709

instance Outputable NewOrData where
Ian Lynagh's avatar
Ian Lynagh committed
710 711
  ppr NewType  = ptext (sLit "newtype")
  ppr DataType = ptext (sLit "data")
712 713 714 715
\end{code}


%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
716
%*                                                                      *
717
\subsection[ConDecl]{A data-constructor declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
718
%*                                                                      *
719 720 721
%************************************************************************

\begin{code}
722 723
type LConDecl name = Located (ConDecl name)

724 725 726 727
-- data T b = forall a. Eq a => MkT a b
--   MkT :: forall b a. Eq a => MkT a b

-- data T b where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
728
--      MkT1 :: Int -> T Int
729 730

-- data T = Int `MkT` Int
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
731
--        | MkT2
732 733

-- data T a where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
734
--      Int `MkT` Int :: T Int
735

736
data ConDecl name
737
  = ConDecl
738 739 740
    { con_name      :: Located name
        -- ^ Constructor name.  This is used for the DataCon itself, and for
        -- the user-callable wrapper Id.
741

742
    , con_explicit  :: HsExplicitFlag
743
        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
744

745 746
    , con_qvars     :: [LHsTyVarBndr name]
        -- ^ Type variables.  Depending on 'con_res' this describes the
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
747
        -- following entities
748
        --
749 750
        --  - ResTyH98:  the constructor's *existential* type variables
        --  - ResTyGADT: *all* the constructor's quantified type variables
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
751 752 753
        --
        -- If con_explicit is Implicit, then con_qvars is irrelevant
        -- until after renaming.  
754

755 756
    , con_cxt       :: LHsContext name
        -- ^ The context.  This /does not/ include the \"stupid theta\" which
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
757
        -- lives only in the 'TyData' decl.
758

759 760
    , con_details   :: HsConDeclDetails name
        -- ^ The main payload
761

762 763
    , con_res       :: ResType name
        -- ^ Result type of the constructor
764

765
    , con_doc       :: Maybe LHsDocString
766
        -- ^ A possible Haddock comment.
767 768 769

    , con_old_rec :: Bool   
        -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
770 771 772
        --                             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
773
    } deriving (Data, Typeable)
774

775 776 777 778 779 780 781
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

782
data ResType name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
783 784 785
   = ResTyH98           -- Constructor was declared using Haskell 98 syntax
   | ResTyGADT (LHsType name)   -- Constructor was declared using GADT-style syntax,
                                --      and here is its result type
786
   deriving (Data, Typeable)
787 788

instance OutputableBndr name => Outputable (ResType name) where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
789
         -- Debugging only
790 791
   ppr ResTyH98 = ptext (sLit "ResTyH98")
   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
792 793
\end{code}

794 795

\begin{code}
796
instance (OutputableBndr name) => Outputable (ConDecl name) where
797 798
    ppr = pprConDecl

799
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
800
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
801 802
                    , con_cxt = cxt, con_details = details
                    , con_res = ResTyH98, con_doc = doc })
803
  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
sof's avatar
sof committed
804
  where
805 806
    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
807
    ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
808

809 810 811
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                    , con_cxt = cxt, con_details = PrefixCon arg_tys
                    , con_res = ResTyGADT res_ty })
812 813
  = ppr con <+> dcolon <+> 
    sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
814 815
  where
    mk_fun_ty a b = noLoc (HsFunTy a b)
sof's avatar
sof committed
816

817 818 819 820
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]
821

822
pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
823
  = pprPanic "pprConDecl" (ppr con)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
824
        -- In GADT syntax we don't allow infix constructors
825 826 827
\end{code}

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
828
%*                                                                      *
829
\subsection[InstDecl]{An instance declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
830
%*                                                                      *
831 832 833
%************************************************************************

\begin{code}
834 835
type LInstDecl name = Located (InstDecl name)

836
data InstDecl name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
837 838 839 840 841 842 843
  = InstDecl    (LHsType name)  -- Context => Class Instance-type
                                -- Using a polytype means that the renamer conveniently
                                -- figures out the quantified type variables for us.
                (LHsBinds name)
                [LSig name]     -- User-supplied pragmatic info
                [LTyClDecl name]-- Associated types (ie, 'TyData' and
                                -- 'TySynonym' only)
844
  deriving (Data, Typeable)
845

846
instance (OutputableBndr name) => Outputable (InstDecl name) where
847 848 849
    ppr (InstDecl inst_ty binds sigs ats)
      | null sigs && null ats && isEmptyBag binds  -- No "where" part
      = top_matter
850

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
851
      | otherwise       -- Laid out
852 853
      = vcat [ top_matter <+> ptext (sLit "where")
             , nest 2 $ pprDeclList (map ppr ats ++
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
854
                                     pprLHsBindsForUser binds sigs) ]
855 856
      where
        top_matter = ptext (sLit "instance") <+> ppr inst_ty
857 858 859

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

864
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
865
%*                                                                      *
866
\subsection[DerivDecl]{A stand-alone instance deriving declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
867
%*                                                                      *
868 869 870 871 872
%************************************************************************

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

dreixel's avatar
dreixel committed
873
data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
874
  deriving (Data, Typeable)
875 876

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

881
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
882
%*                                                                      *
883
\subsection[DefaultDecl]{A @default@ declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
884
%*                                                                      *
885 886 887 888 889 890 891
%************************************************************************

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}
892 893
type LDefaultDecl name = Located (DefaultDecl name)

894
data DefaultDecl name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
895
  = DefaultDecl [LHsType name]