HsDecls.hs 66.9 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
5

6
{-# LANGUAGE CPP #-}
7 8
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
             DeriveTraversable #-}
9 10 11 12 13
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
14 15
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
16

17 18
-- | Abstract syntax of global declarations.
--
19
-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
20
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
21
module HsDecls (
22
  -- * Toplevel declarations
23
  HsDecl(..), LHsDecl, HsDataDefn(..),
24
  -- ** Class or type declarations
25 26
  TyClDecl(..), LTyClDecl,
  TyClGroup(..), tyClGroupConcat, mkTyClGroup,
27 28
  isClassDecl, isDataDecl, isSynDecl, tcdName,
  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
29
  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
30 31 32
  tyFamInstDeclName, tyFamInstDeclLName,
  countTyClDecls, pprTyClDeclFlavour,
  tyClDeclLName, tyClDeclTyVars,
33
  hsDeclHasCusk, famDeclHasCusk,
34
  FamilyDecl(..), LFamilyDecl,
35

36
  -- ** Instance declarations
37
  InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
38 39
  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
40
  TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
Alan Zimmerman's avatar
Alan Zimmerman committed
41
  HsTyPats,
42
  LClsInstDecl, ClsInstDecl(..),
43

44 45 46
  -- ** Standalone deriving declarations
  DerivDecl(..), LDerivDecl,
  -- ** @RULE@ declarations
Alan Zimmerman's avatar
Alan Zimmerman committed
47
  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
48
  collectRuleBndrSigTys,
Alan Zimmerman's avatar
Alan Zimmerman committed
49
  flattenRuleDecls,
50 51
  -- ** @VECTORISE@ declarations
  VectDecl(..), LVectDecl,
52
  lvectDeclName, lvectInstDecl,
53 54
  -- ** @default@ declarations
  DefaultDecl(..), LDefaultDecl,
55
  -- ** Template haskell declaration splice
56
  SpliceExplicitFlag(..),
57
  SpliceDecl(..), LSpliceDecl,
58 59
  -- ** Foreign function interface declarations
  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
60
  noForeignImportCoercionYet, noForeignExportCoercionYet,
61
  CImportSpec(..),
62
  -- ** Data-constructor declarations
63 64
  ConDecl(..), LConDecl, ResType(..),
  HsConDeclDetails, hsConDeclArgTys,
65 66 67 68
  -- ** Document comments
  DocDecl(..), LDocDecl, docDeclDoc,
  -- ** Deprecations
  WarnDecl(..),  LWarnDecl,
Alan Zimmerman's avatar
Alan Zimmerman committed
69
  WarnDecls(..), LWarnDecls,
70
  -- ** Annotations
71
  AnnDecl(..), LAnnDecl,
72
  AnnProvenance(..), annProvenanceName_maybe,
73 74
  -- ** Role annotations
  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
75 76

  -- * Grouping
77
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
78

79
    ) where
80 81

-- friends:
82
import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprUntypedSplice )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
83
        -- Because Expr imports Decls via HsBracket
84

85 86
import HsBinds
import HsPat
87
import HsTypes
88
import HsDoc
89
import TyCon
90
import Name
91
import BasicTypes
92
import Coercion
93
import ForeignCall
94 95
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId )
import NameSet
96 97

-- others:
98
import InstEnv
99
import Class
100
import Outputable
101 102
import Util
import SrcLoc
rrt's avatar
rrt committed
103
import FastString
104

105
import Bag
106
import Data.Data        hiding (TyCon,Fixity)
107 108 109 110
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
import Data.Traversable ( Traversable )
#endif
111
import Data.Maybe
112

Austin Seipp's avatar
Austin Seipp committed
113 114 115
{-
************************************************************************
*                                                                      *
116
\subsection[HsDecl]{Declarations}
Austin Seipp's avatar
Austin Seipp committed
117 118 119
*                                                                      *
************************************************************************
-}
120

121
type LHsDecl id = Located (HsDecl id)
Alan Zimmerman's avatar
Alan Zimmerman committed
122 123 124 125
        -- ^ When in a list this may have
        --
        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
        --
126

127
-- | A Haskell Declaration
128
data HsDecl id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
129 130
  = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
  | InstD       (InstDecl  id)    -- ^ An instance declaration.
131
  | DerivD      (DerivDecl id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
132 133 134
  | ValD        (HsBind id)
  | SigD        (Sig id)
  | DefD        (DefaultDecl id)
135
  | ForD        (ForeignDecl id)
Alan Zimmerman's avatar
Alan Zimmerman committed
136
  | WarningD    (WarnDecls id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
137
  | AnnD        (AnnDecl id)
Alan Zimmerman's avatar
Alan Zimmerman committed
138
  | RuleD       (RuleDecls id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
139 140 141 142
  | VectD       (VectDecl id)
  | SpliceD     (SpliceDecl id)
  | DocD        (DocDecl)
  | QuasiQuoteD (HsQuasiQuote id)
143
  | RoleAnnotD  (RoleAnnotDecl id)
144 145
  deriving (Typeable)
deriving instance (DataId id) => Data (HsDecl id)
146

147 148

-- NB: all top-level fixity decls are contained EITHER
149
-- EITHER SigDs
150 151 152
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
153 154 155 156 157
--      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
158 159
--
-- The latter is for class methods only
160

161
-- | A 'HsDecl' is categorised into a 'HsGroup' before being
162 163 164
-- fed to the renamer.
data HsGroup id
  = HsGroup {
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
165
        hs_valds  :: HsValBinds id,
166
        hs_splcds :: [LSpliceDecl id],
167

168
        hs_tyclds :: [TyClGroup id],
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
169
                -- A list of mutually-recursive groups
170
                -- No family-instances here; they are in hs_instds
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
171 172
                -- Parser generates a singleton list;
                -- renamer does dependency analysis
173

174 175 176
        hs_instds  :: [LInstDecl id],
                -- Both class and family instance declarations in here

177
        hs_derivds :: [LDerivDecl id],
178

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

183 184
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
Alan Zimmerman's avatar
Alan Zimmerman committed
185
        hs_warnds :: [LWarnDecls id],
186
        hs_annds  :: [LAnnDecl id],
Alan Zimmerman's avatar
Alan Zimmerman committed
187
        hs_ruleds :: [LRuleDecls id],
188
        hs_vects  :: [LVectDecl id],
189

190
        hs_docs   :: [LDocDecl]
191 192
  } deriving (Typeable)
deriving instance (DataId id) => Data (HsGroup id)
193

194 195 196 197
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

198
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [],
199
                       hs_derivds = [],
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
200 201 202
                       hs_fixds = [], hs_defds = [], hs_annds = [],
                       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
                       hs_valds = error "emptyGroup hs_valds: Can't happen",
203
                       hs_splcds = [],
204
                       hs_docs = [] }
205 206

appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
207 208
appendGroups
    HsGroup {
209
        hs_valds  = val_groups1,
210
        hs_splcds = spliceds1,
211
        hs_tyclds = tyclds1,
212
        hs_instds = instds1,
213
        hs_derivds = derivds1,
214
        hs_fixds  = fixds1,
215 216
        hs_defds  = defds1,
        hs_annds  = annds1,
217
        hs_fords  = fords1,
218 219 220
        hs_warnds = warnds1,
        hs_ruleds = rulds1,
        hs_vects = vects1,
221
  hs_docs   = docs1 }
222
    HsGroup {
223
        hs_valds  = val_groups2,
224
        hs_splcds = spliceds2,
225
        hs_tyclds = tyclds2,
226
        hs_instds = instds2,
227
        hs_derivds = derivds2,
228
        hs_fixds  = fixds2,
229 230
        hs_defds  = defds2,
        hs_annds  = annds2,
231
        hs_fords  = fords2,
232 233 234 235
        hs_warnds = warnds2,
        hs_ruleds = rulds2,
        hs_vects  = vects2,
        hs_docs   = docs2 }
236 237
  =
    HsGroup {
238
        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
239 240
        hs_splcds = spliceds1 ++ spliceds2,
        hs_tyclds = tyclds1 ++ tyclds2,
241
        hs_instds = instds1 ++ instds2,
242
        hs_derivds = derivds1 ++ derivds2,
243 244 245
        hs_fixds  = fixds1 ++ fixds2,
        hs_annds  = annds1 ++ annds2,
        hs_defds  = defds1 ++ defds2,
246
        hs_fords  = fords1 ++ fords2,
247 248 249 250
        hs_warnds = warnds1 ++ warnds2,
        hs_ruleds = rulds1 ++ rulds2,
        hs_vects  = vects1 ++ vects2,
        hs_docs   = docs1  ++ docs2 }
251

252
instance OutputableBndr name => Outputable (HsDecl name) where
253 254 255 256 257 258 259 260
    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
261
    ppr (VectD vect)            = ppr vect
Ian Lynagh's avatar
Ian Lynagh committed
262
    ppr (WarningD wd)           = ppr wd
263
    ppr (AnnD ad)               = ppr ad
264 265
    ppr (SpliceD dd)            = ppr dd
    ppr (DocD doc)              = ppr doc
266
    ppr (QuasiQuoteD qq)        = ppr qq
267
    ppr (RoleAnnotD ra)         = ppr ra
268 269 270

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
271 272
                   hs_tyclds = tycl_decls,
                   hs_instds = inst_decls,
273
                   hs_derivds = deriv_decls,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
274 275 276 277 278 279 280
                   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 })
281 282
        = vcat_mb empty
            [ppr_ds fix_decls, ppr_ds default_decls,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
283 284 285
             ppr_ds deprec_decls, ppr_ds ann_decls,
             ppr_ds rule_decls,
             ppr_ds vect_decls,
286 287
             if isEmptyValBinds val_decls
                then Nothing
288
                else Just (ppr val_decls),
289
             ppr_ds (tyClGroupConcat tycl_decls),
290
             ppr_ds inst_decls,
291
             ppr_ds deriv_decls,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
292 293
             ppr_ds foreign_decls]
        where
294
          ppr_ds :: Outputable a => [a] -> Maybe SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
295 296
          ppr_ds [] = Nothing
          ppr_ds ds = Just (vcat (map ppr ds))
297 298

          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
299
          -- Concatenate vertically with white-space between non-blanks
300 301 302
          vcat_mb _    []             = empty
          vcat_mb gap (Nothing : ds) = vcat_mb gap ds
          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
303

304 305 306 307
data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)
                          ImplicitSplice   -- <=> f x y,  i.e. a naked top level expression
    deriving (Data, Typeable)

308
type LSpliceDecl name = Located (SpliceDecl name)
309
data SpliceDecl id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
310
  = SpliceDecl                  -- Top level splice
311
        (Located (HsSplice id))
312
        SpliceExplicitFlag
313 314
    deriving (Typeable)
deriving instance (DataId id) => Data (SpliceDecl id)
315 316

instance OutputableBndr name => Outputable (SpliceDecl name) where
317
   ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
318

Austin Seipp's avatar
Austin Seipp committed
319 320 321
{-
************************************************************************
*                                                                      *
322
\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
Austin Seipp's avatar
Austin Seipp committed
323 324
*                                                                      *
************************************************************************
325

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
326 327 328
                --------------------------------
                        THE NAMING STORY
                --------------------------------
329

330 331
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
332 333 334

"Implicit" (or "system") binders
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335
  Each data type decl defines
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
336 337
        a worker name for each constructor
        to-T and from-T convertors
338
  Each class decl defines
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
339 340 341 342
        a tycon for the class
        a data constructor for that tycon
        the worker for that constructor
        a selector for each superclass
343

344 345
All have occurrence names that are derived uniquely from their parent
declaration.
346 347 348 349 350 351 352

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:
353
 - Ensure they "point to" the parent data/class decl
354
   when loading that decl from an interface file
355 356 357 358 359
   (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
360

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

364 365 366 367 368 369 370 371 372 373 374 375 376 377 378
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:
379

380 381 382 383 384
 - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
   This is done by RdrHsSyn.mkClassOpSigDM

 - The renamer renames it to a Name

385
 - During typechecking, we generate a binding for each $dm for
386
   which there's a programmer-supplied default method:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
387 388 389 390
        class Foo a where
          op1 :: <type>
          op2 :: <type>
          op1 = ...
391 392 393 394 395 396 397
   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
398 399 400
        class Foo a where
          op1 = :: <type>       -- NB the '='
          op2   :: <type>
401 402 403 404 405
    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
406
    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)
407 408 409 410 411 412 413 414 415 416 417 418 419 420
    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
421 422
        instance {Eq Int} = dEqInt
        dEqInt :: {Eq Int} <pragma info>
423 424 425 426 427 428 429 430 431 432 433

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

434
  - The occurrence name it chooses is derived from the instance decl (just for
435 436
    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
437 438
        instance Foo [Int]  where ...
        instance Foo [Bool] where ...
439 440
    These might both be dFooList

441
  - The CoreTidy phase externalises the name, and ensures the occurrence name is
442 443
    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.

444
  - We can take this relaxed approach (changing the occurrence name later)
445 446 447 448 449 450 451 452 453
    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.
454

455 456
  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
    suck in the dfun binding
Austin Seipp's avatar
Austin Seipp committed
457
-}
458

459 460
type LTyClDecl name = Located (TyClDecl name)

461
-- | A type or class declaration.
462
data TyClDecl name
Yuras's avatar
Yuras committed
463
  = -- | @type/data family T :: *->*@
Alan Zimmerman's avatar
Alan Zimmerman committed
464 465 466 467 468 469 470
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnData',
    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnWhere',
    --             'ApiAnnotation.AnnOpen','ApiAnnotation.AnnDcolon',
    --             'ApiAnnotation.AnnClose'

471
    FamDecl { tcdFam :: FamilyDecl name }
472

473
  | -- | @type@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
474 475 476
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnEqual',
477
    SynDecl { tcdLName  :: Located name            -- ^ Type constructor
478
            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
479
                                                  --   these include outer binders
480
            , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
481
            , tcdFVs    :: PostRn name NameSet }
482 483

  | -- | @data@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
484 485 486 487 488
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
    --              'ApiAnnotation.AnnFamily',
    --              'ApiAnnotation.AnnNewType',
    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnWhere'
489 490 491
    DataDecl { tcdLName    :: Located name        -- ^ Type constructor
             , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
                                                  --   these include outer binders
492 493 494
                                                  -- Eg  class T a where
                                                  --       type F a :: *
                                                  --       type F a = a -> a
495
                                                  -- Here the type decl for 'f' includes 'a'
496
                                                  -- in its tcdTyVars
497
             , tcdDataDefn :: HsDataDefn name
498
             , tcdFVs      :: PostRn name NameSet }
499

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
500 501
  | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                tcdLName   :: Located name,             -- ^ Name of the class
502
                tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
Alan Zimmerman's avatar
Alan Zimmerman committed
503 504
                tcdFDs     :: [Located (FunDep (Located name))],
                                                        -- ^ Functional deps
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
505 506
                tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                tcdMeths   :: LHsBinds name,            -- ^ Default methods
Alan Zimmerman's avatar
Alan Zimmerman committed
507
                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types;
508
                tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
509
                tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
510
                tcdFVs     :: PostRn name NameSet
511
    }
Alan Zimmerman's avatar
Alan Zimmerman committed
512 513 514 515 516 517
        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
        --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
        --           'ApiAnnotation.AnnClose'
        --   - The tcdFDs will have 'ApiAnnotation.AnnVbar',
        --                          'ApiAnnotation.AnnComma'
        --                          'ApiAnnotation.AnnRarrow'
518 519 520

  deriving (Typeable)
deriving instance (DataId id) => Data (TyClDecl id)
521

522 523 524 525 526 527 528 529
 -- This is used in TcTyClsDecls to represent
 -- strongly connected components of decls
 -- No familiy instances in here
 -- The role annotations must be grouped with their decls for the
 -- type-checker to infer roles correctly
data TyClGroup name
  = TyClGroup { group_tyclds :: [LTyClDecl name]
              , group_roles  :: [LRoleAnnotDecl name] }
530 531
    deriving (Typeable)
deriving instance (DataId id) => Data (TyClGroup id)
532 533 534 535 536 537 538

tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
tyClGroupConcat = concatMap group_tyclds

mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }

539 540
type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
541
  { fdInfo    :: FamilyInfo name            -- type or data, closed or open
542 543 544
  , fdLName   :: Located name               -- type constructor
  , fdTyVars  :: LHsTyVarBndrs name         -- type variables
  , fdKindSig :: Maybe (LHsKind name) }     -- result kind
545 546
  deriving( Typeable )
deriving instance (DataId id) => Data (FamilyDecl id)
547

548 549 550
data FamilyInfo name
  = DataFamily
  | OpenTypeFamily
551 552
     -- this list might be empty, if we're in an hs-boot file and the user
     -- said "type family Foo x where .."
553
  | ClosedTypeFamily [LTyFamInstEqn name]
554 555
  deriving( Typeable )
deriving instance (DataId name) => Data (FamilyInfo name)
dreixel's avatar
dreixel committed
556

Austin Seipp's avatar
Austin Seipp committed
557
{-
558
------------------------------
559
Simple classifiers
Austin Seipp's avatar
Austin Seipp committed
560
-}
561

562
-- | @True@ <=> argument is a @data@\/@newtype@
563 564
-- declaration.
isDataDecl :: TyClDecl name -> Bool
565 566
isDataDecl (DataDecl {}) = True
isDataDecl _other        = False
567

568 569
-- | type or type instance declaration
isSynDecl :: TyClDecl name -> Bool
570 571
isSynDecl (SynDecl {})   = True
isSynDecl _other        = False
572

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

578
-- | type/data family declaration
579
isFamilyDecl :: TyClDecl name -> Bool
580
isFamilyDecl (FamDecl {})  = True
581
isFamilyDecl _other        = False
582 583 584

-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
585 586 587 588 589
isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
  OpenTypeFamily      -> True
  ClosedTypeFamily {} -> True
  _                   -> False
isTypeFamilyDecl _ = False
590

591 592 593 594 595 596 597 598 599 600
-- | open type family info
isOpenTypeFamilyInfo :: FamilyInfo name -> Bool
isOpenTypeFamilyInfo OpenTypeFamily = True
isOpenTypeFamilyInfo _              = False

-- | closed type family info
isClosedTypeFamilyInfo :: FamilyInfo name -> Bool
isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True
isClosedTypeFamilyInfo _                     = False

601 602
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
603
isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
604
isDataFamilyDecl _other      = False
605

Austin Seipp's avatar
Austin Seipp committed
606
-- Dealing with names
607

608
tyFamInstDeclName :: TyFamInstDecl name -> name
609 610
tyFamInstDeclName = unLoc . tyFamInstDeclLName

611
tyFamInstDeclLName :: TyFamInstDecl name -> Located name
612
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
613
                     (L _ (TyFamEqn { tfe_tycon = ln })) })
614 615 616 617 618
  = ln

tyClDeclLName :: TyClDecl name -> Located name
tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
tyClDeclLName decl = tcdLName decl
619

620
tcdName :: TyClDecl name -> name
621 622
tcdName = unLoc . tyClDeclLName

623
tyClDeclTyVars :: TyClDecl name -> LHsTyVarBndrs name
624 625
tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
tyClDeclTyVars d = tcdTyVars d
626

627 628
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
        -- class, synonym decls, data, newtype, family decls
629
countTyClDecls decls
630 631 632 633
 = (count isClassDecl    decls,
    count isSynDecl      decls,  -- excluding...
    count isDataTy       decls,  -- ...family...
    count isNewTy        decls,  -- ...instances
634
    count isFamilyDecl   decls)
sof's avatar
sof committed
635
 where
636 637
   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
   isDataTy _                                                       = False
638

639 640
   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
   isNewTy _                                                      = False
641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662

-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [Complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl name -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
  = hsTvbAllKinded tyvars && rhs_annotated rhs
  where
    rhs_annotated (L _ ty) = case ty of
      HsParTy lty  -> rhs_annotated lty
      HsKindSig {} -> True
      _            -> False
hsDeclHasCusk (DataDecl { tcdTyVars = tyvars })  = hsTvbAllKinded tyvars
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars

-- | Does this family declaration have a complete, user-supplied kind signature?
famDeclHasCusk :: FamilyDecl name -> Bool
famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _
                           , fdTyVars = tyvars
                           , fdKindSig = m_sig })
  = hsTvbAllKinded tyvars && isJust m_sig
famDeclHasCusk _ = True  -- all open families have CUSKs!
663

Austin Seipp's avatar
Austin Seipp committed
664
{-
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686
Note [Complete user-supplied kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We kind-check declarations differently if they have a complete, user-supplied
kind signature (CUSK). This is because we can safely generalise a CUSKed
declaration before checking all of the others, supporting polymorphic recursion.
See https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
and #9200 for lots of discussion of how we got here.

A declaration has a CUSK if we can know its complete kind without doing any inference,
at all. Here are the rules:

 - A class or datatype is said to have a CUSK if and only if all of its type
variables are annotated. Its result kind is, by construction, Constraint or *
respectively.

 - A type synonym has a CUSK if and only if all of its type variables and its
RHS are annotated with kinds.

 - A closed type family is said to have a CUSK if and only if all of its type
variables and its return type are annotated.

 - An open type family always has a CUSK -- unannotated type variables (and return type) default to *.
Austin Seipp's avatar
Austin Seipp committed
687
-}
688

689
instance OutputableBndr name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
690
              => Outputable (TyClDecl name) where
691

692 693 694 695
    ppr (FamDecl { tcdFam = decl }) = ppr decl
    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
      = hang (ptext (sLit "type") <+>
              pp_vanilla_decl_head ltycon tyvars [] <+> equals)
696
          4 (ppr rhs)
697

698 699
    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
700

701
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
702
                    tcdFDs  = fds,
703 704 705
                    tcdSigs = sigs, tcdMeths = methods,
                    tcdATs = ats, tcdATDefs = at_defs})
      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
706 707
      = top_matter

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
708
      | otherwise       -- Laid out
709
      = vcat [ top_matter <+> ptext (sLit "where")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
710
             , nest 2 $ pprDeclList (map ppr ats ++
711
                                     map ppr_fam_deflt_eqn at_defs ++
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
712
                                     pprLHsBindsForUser methods sigs) ]
713
      where
714
        top_matter = ptext (sLit "class")
715
                     <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
716
                     <+> pprFundeps (map unLoc fds)
717

718 719 720 721 722
instance OutputableBndr name => Outputable (TyClGroup name) where
  ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
    = ppr tyclds $$
      ppr roles

723
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
724
  ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
725
                    fdTyVars = tyvars, fdKindSig = mb_kind})
726 727
      = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
             , nest 2 $ pp_eqns ]
728 729 730 731
        where
          pp_kind = case mb_kind of
                      Nothing   -> empty
                      Just kind -> dcolon <+> ppr kind
732 733
          (pp_where, pp_eqns) = case info of
            ClosedTypeFamily eqns -> ( ptext (sLit "where")
734 735
                                     , if null eqns
                                       then ptext (sLit "..")
736
                                       else vcat $ map ppr_fam_inst_eqn eqns )
737 738 739 740 741 742
            _                     -> (empty, empty)

pprFlavour :: FamilyInfo name -> SDoc
pprFlavour DataFamily            = ptext (sLit "data family")
pprFlavour OpenTypeFamily        = ptext (sLit "type family")
pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
743

744 745
instance Outputable (FamilyInfo name) where
  ppr = pprFlavour
746

747 748
pp_vanilla_decl_head :: OutputableBndr name
   => Located name
749
   -> LHsTyVarBndrs name
750 751 752
   -> HsContext name
   -> SDoc
pp_vanilla_decl_head thing tyvars context
753
 = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
754

755
pp_fam_inst_lhs :: OutputableBndr name
756
   => Located name
757
   -> HsTyPats name
758
   -> HsContext name
759
   -> SDoc
760 761
pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
   = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
762
          , hsep (map (pprParendHsType.unLoc) typats)]
763

764
pprTyClDeclFlavour :: TyClDecl a -> SDoc
765 766 767 768 769 770
pprTyClDeclFlavour (ClassDecl {})   = ptext (sLit "class")
pprTyClDeclFlavour (SynDecl {})     = ptext (sLit "type")
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
  = pprFlavour info
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
  = ppr nd
771

Austin Seipp's avatar
Austin Seipp committed
772 773 774
{-
************************************************************************
*                                                                      *
775
\subsection[ConDecl]{A data-constructor declaration}
Austin Seipp's avatar
Austin Seipp committed
776 777 778
*                                                                      *
************************************************************************
-}
779 780 781 782

data HsDataDefn name   -- The payload of a data type defn
                       -- Used *both* for vanilla data declarations,
                       --       *and* for data family instances
Gabor Greif's avatar
Gabor Greif committed
783
  = -- | Declares a data type or newtype, giving its constructors
784 785 786 787 788 789
    -- @
    --  data/newtype T a = <constrs>
    --  data/newtype instance T [a] = <constrs>
    -- @
    HsDataDefn { dd_ND     :: NewOrData,
                 dd_ctxt   :: LHsContext name,           -- ^ Context
790
                 dd_cType  :: Maybe (Located CType),
791 792 793
                 dd_kindSig:: Maybe (LHsKind name),
                     -- ^ Optional kind signature.
                     --
794
                     -- @(Just k)@ for a GADT-style @data@,
795 796 797 798 799 800 801 802 803 804 805 806
                     -- or @data instance@ decl, with explicit kind sig
                     --
                     -- Always @Nothing@ for H98-syntax decls

                 dd_cons   :: [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'.

807
                 dd_derivs :: Maybe (Located [LHsType name])
808 809 810 811 812 813 814 815 816
                     -- ^ Derivings; @Nothing@ => not specified,
                     --              @Just []@ => derive exactly what is asked
                     --
                     -- 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
Alan Zimmerman's avatar
Alan Zimmerman committed
817 818 819 820 821
                     --
                     --  - 'ApiAnnotation.AnnKeywordId' :
                     --       'ApiAnnotation.AnnDeriving',
                     --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
   }
822 823
    deriving( Typeable )
deriving instance (DataId id) => Data (HsDataDefn id)
824 825 826 827 828 829

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

830
type LConDecl name = Located (ConDecl name)
Alan Zimmerman's avatar
Alan Zimmerman committed
831 832
      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
      --   in a GADT constructor list
833

Alan Zimmerman's avatar
Alan Zimmerman committed
834 835 836
-- |
--
-- @
837 838
-- data T b = forall a. Eq a => MkT a b
--   MkT :: forall b a. Eq a => MkT a b
Alan Zimmerman's avatar
Alan Zimmerman committed
839
--
840
-- data T b where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
841
--      MkT1 :: Int -> T Int
Alan Zimmerman's avatar
Alan Zimmerman committed
842
--
843
-- data T = Int `MkT` Int
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
844
--        | MkT2
Alan Zimmerman's avatar
Alan Zimmerman committed
845
--
846
-- data T a where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
847
--      Int `MkT` Int :: T Int
Alan Zimmerman's avatar
Alan Zimmerman committed
848 849 850 851 852 853 854
-- @
--
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',
--            'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',
--            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',
--            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',
--            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'
855
data ConDecl name
856
  = ConDecl
857 858
    { con_names     :: [Located name]
        -- ^ Constructor names.  This is used for the DataCon itself, and for
859
        -- the user-callable wrapper Id.
860 861
        -- It is a list to deal with GADT constructors of the form
        --   T1, T2, T3 :: <payload>
862
    , con_explicit  :: HsExplicitFlag
863
        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
864

865
    , con_qvars     :: LHsTyVarBndrs name
866
        -- ^ Type variables.  Depending on 'con_res' this describes the
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
867
        -- following entities
868
        --