HsDecls.hs 65.2 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,
41
  LClsInstDecl, ClsInstDecl(..),
42

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

  -- * Grouping
74
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
75

76
    ) where
77 78

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

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

-- others:
95
import InstEnv
96
import Class
97
import Outputable
98 99
import Util
import SrcLoc
rrt's avatar
rrt committed
100
import FastString
101

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

Austin Seipp's avatar
Austin Seipp committed
110 111 112
{-
************************************************************************
*                                                                      *
113
\subsection[HsDecl]{Declarations}
Austin Seipp's avatar
Austin Seipp committed
114 115 116
*                                                                      *
************************************************************************
-}
117

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

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

144 145

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

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

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

171 172 173
        hs_instds  :: [LInstDecl id],
                -- Both class and family instance declarations in here

174
        hs_derivds :: [LDerivDecl id],
175

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

180 181 182 183 184 185
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
        hs_warnds :: [LWarnDecl id],
        hs_annds  :: [LAnnDecl id],
        hs_ruleds :: [LRuleDecl id],
        hs_vects  :: [LVectDecl id],
186

187
        hs_docs   :: [LDocDecl]
188 189
  } deriving (Typeable)
deriving instance (DataId id) => Data (HsGroup id)
190

191 192 193 194
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

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

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

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

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

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

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

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

instance OutputableBndr name => Outputable (SpliceDecl name) where
314
   ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
315

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
323 324 325
                --------------------------------
                        THE NAMING STORY
                --------------------------------
326

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

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

341 342
All have occurrence names that are derived uniquely from their parent
declaration.
343 344 345 346 347 348 349

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

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

361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
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:
376

377 378 379 380 381
 - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
   This is done by RdrHsSyn.mkClassOpSigDM

 - The renamer renames it to a Name

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

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

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

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

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

452 453
  - 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
454
-}
455

456 457
type LTyClDecl name = Located (TyClDecl name)

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

468
    FamDecl { tcdFam :: FamilyDecl name }
469

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

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

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

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

518 519 520 521 522 523 524 525
 -- 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] }
526 527
    deriving (Typeable)
deriving instance (DataId id) => Data (TyClGroup id)
528 529 530 531 532 533 534

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
553
{-
554
------------------------------
555
Simple classifiers
Austin Seipp's avatar
Austin Seipp committed
556
-}
557

558
-- | @True@ <=> argument is a @data@\/@newtype@
559 560
-- declaration.
isDataDecl :: TyClDecl name -> Bool
561 562
isDataDecl (DataDecl {}) = True
isDataDecl _other        = False
563

564 565
-- | type or type instance declaration
isSynDecl :: TyClDecl name -> Bool
566 567
isSynDecl (SynDecl {})   = True
isSynDecl _other        = False
568

569 570
-- | type class
isClassDecl :: TyClDecl name -> Bool
571
isClassDecl (ClassDecl {}) = True
572
isClassDecl _              = False
573

574
-- | type/data family declaration
575
isFamilyDecl :: TyClDecl name -> Bool
576
isFamilyDecl (FamDecl {})  = True
577
isFamilyDecl _other        = False
578 579 580

-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
581 582 583 584 585
isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
  OpenTypeFamily      -> True
  ClosedTypeFamily {} -> True
  _                   -> False
isTypeFamilyDecl _ = False
586

587 588 589 590 591 592 593 594 595 596
-- | 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

597 598
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
599
isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
600
isDataFamilyDecl _other      = False
601

Austin Seipp's avatar
Austin Seipp committed
602
-- Dealing with names
603

604 605 606 607 608 609
tyFamInstDeclName :: OutputableBndr name
                  => TyFamInstDecl name -> name
tyFamInstDeclName = unLoc . tyFamInstDeclLName

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

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

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

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

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

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

-- | 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!
661

Austin Seipp's avatar
Austin Seipp committed
662
{-
663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684
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
685
-}
686

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

690 691 692 693
    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)
694
          4 (ppr rhs)
695

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

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

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

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

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

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

742 743
instance Outputable (FamilyInfo name) where
  ppr = pprFlavour
744

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

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

762
pprTyClDeclFlavour :: TyClDecl a -> SDoc
763 764 765 766 767 768
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
769

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

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
781
  = -- | Declares a data type or newtype, giving its constructors
782 783 784 785 786 787
    -- @
    --  data/newtype T a = <constrs>
    --  data/newtype instance T [a] = <constrs>
    -- @
    HsDataDefn { dd_ND     :: NewOrData,
                 dd_ctxt   :: LHsContext name,           -- ^ Context
788
                 dd_cType  :: Maybe (Located CType),
789 790 791
                 dd_kindSig:: Maybe (LHsKind name),
                     -- ^ Optional kind signature.
                     --
792
                     -- @(Just k)@ for a GADT-style @data@,
793 794 795 796 797 798 799 800 801 802 803 804
                     -- 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'.

805
                 dd_derivs :: Maybe (Located [LHsType name])
806 807 808 809 810 811 812 813 814
                     -- ^ 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
815 816 817 818 819
                     --
                     --  - 'ApiAnnotation.AnnKeywordId' :
                     --       'ApiAnnotation.AnnDeriving',
                     --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
   }
820 821
    deriving( Typeable )
deriving instance (DataId id) => Data (HsDataDefn id)
822 823 824 825 826 827

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

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

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