HsDecls.hs 77.6 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 7
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
             DeriveTraversable #-}
8 9 10 11 12
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                      -- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
13
{-# LANGUAGE FlexibleInstances #-}
14

15 16
-- | Abstract syntax of global declarations.
--
17
-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,
18
-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
19
module HsDecls (
20
  -- * Toplevel declarations
21 22
  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,

23
  -- ** Class or type declarations
24
  TyClDecl(..), LTyClDecl,
25 26
  TyClGroup(..), mkTyClGroup, emptyTyClGroup,
  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
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,
49
  flattenRuleDecls, pprFullRuleName,
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
Alan Zimmerman's avatar
Alan Zimmerman committed
63
  ConDecl(..), LConDecl,
64
  HsConDeclDetails, hsConDeclArgTys,
Alan Zimmerman's avatar
Alan Zimmerman committed
65 66 67
  getConNames,
  getConDetails,
  gadtDeclDetails,
68 69 70 71
  -- ** Document comments
  DocDecl(..), LDocDecl, docDeclDoc,
  -- ** Deprecations
  WarnDecl(..),  LWarnDecl,
Alan Zimmerman's avatar
Alan Zimmerman committed
72
  WarnDecls(..), LWarnDecls,
73
  -- ** Annotations
74
  AnnDecl(..), LAnnDecl,
75
  AnnProvenance(..), annProvenanceName_maybe,
76 77
  -- ** Role annotations
  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
Jan Stolarek's avatar
Jan Stolarek committed
78 79 80
  -- ** Injective type families
  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
  resultVariableName,
81 82

  -- * Grouping
83
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls
84

85
    ) where
86 87

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

91
import HsBinds
92
import HsTypes
93
import HsDoc
94
import TyCon
95
import Name
96
import BasicTypes
97
import Coercion
98
import ForeignCall
99
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )
100
import NameSet
101 102

-- others:
103
import InstEnv
104
import Class
105
import Outputable
106 107 108
import Util
import SrcLoc

109
import Bag
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
110
import Maybes
111
import Data.Data        hiding (TyCon,Fixity)
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 128
-- For details on above see note [Api annotations] in ApiAnnotation

129
-- | A Haskell Declaration
130
data HsDecl id
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
  = TyClD       (TyClDecl id)      -- ^ Type or Class Declaration
  | InstD       (InstDecl  id)     -- ^ Instance declaration
  | DerivD      (DerivDecl id)     -- ^ Deriving declaration
  | ValD        (HsBind id)        -- ^ Value declaration
  | SigD        (Sig id)           -- ^ Signature declaration
  | DefD        (DefaultDecl id)   -- ^ 'default' declaration
  | ForD        (ForeignDecl id)   -- ^ Foreign declaration
  | WarningD    (WarnDecls id)     -- ^ Warning declaration
  | AnnD        (AnnDecl id)       -- ^ Annotation declaration
  | RuleD       (RuleDecls id)     -- ^ Rule declaration
  | VectD       (VectDecl id)      -- ^ Vectorise declaration
  | SpliceD     (SpliceDecl id)    -- ^ Splice declaration
                                   -- (Includes quasi-quotes)
  | DocD        (DocDecl)          -- ^ Documentation comment declaration
  | RoleAnnotD  (RoleAnnotDecl id) -- ^ Role annotation declaration
146
deriving instance (DataId id) => Data (HsDecl id)
147

148 149

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

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

171
        hs_tyclds :: [TyClGroup id],
172 173
                -- A list of mutually-recursive groups;
                -- This includes `InstDecl`s as well;
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
174 175
                -- Parser generates a singleton list;
                -- renamer does dependency analysis
176

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 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 199 200 201
hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
hsGroupInstDecls = (=<<) group_instds . hs_tyclds

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

appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
210 211
appendGroups
    HsGroup {
212
        hs_valds  = val_groups1,
213
        hs_splcds = spliceds1,
214
        hs_tyclds = tyclds1,
215
        hs_derivds = derivds1,
216
        hs_fixds  = fixds1,
217 218
        hs_defds  = defds1,
        hs_annds  = annds1,
219
        hs_fords  = fords1,
220 221 222
        hs_warnds = warnds1,
        hs_ruleds = rulds1,
        hs_vects = vects1,
223
  hs_docs   = docs1 }
224
    HsGroup {
225
        hs_valds  = val_groups2,
226
        hs_splcds = spliceds2,
227
        hs_tyclds = tyclds2,
228
        hs_derivds = derivds2,
229
        hs_fixds  = fixds2,
230 231
        hs_defds  = defds2,
        hs_annds  = annds2,
232
        hs_fords  = fords2,
233 234 235 236
        hs_warnds = warnds2,
        hs_ruleds = rulds2,
        hs_vects  = vects2,
        hs_docs   = docs2 }
237 238
  =
    HsGroup {
239
        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
240 241
        hs_splcds = spliceds1 ++ spliceds2,
        hs_tyclds = tyclds1 ++ tyclds2,
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 (OutputableBndrId 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 (RoleAnnotD ra)         = ppr ra
267

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

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

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

306
-- | Located Splice Declaration
307
type LSpliceDecl name = Located (SpliceDecl name)
308 309

-- | Splice Declaration
310
data SpliceDecl id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
311
  = SpliceDecl                  -- Top level splice
312
        (Located (HsSplice id))
313
        SpliceExplicitFlag
314
deriving instance (DataId id) => Data (SpliceDecl id)
315

316
instance (OutputableBndrId name) => Outputable (SpliceDecl name) where
317
   ppr (SpliceDecl (L _ e) _) = pprSplice e
318

Austin Seipp's avatar
Austin Seipp committed
319 320 321
{-
************************************************************************
*                                                                      *
322
            Type and class declarations
Austin Seipp's avatar
Austin Seipp committed
323 324
*                                                                      *
************************************************************************
325

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

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

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

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

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

362 363 364 365 366 367
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
368 369
   the ClassOpSig (in HsBinds), in the DefMethInfo field.
   (DefMethInfo is defined in Class.hs)
370 371 372 373 374 375 376

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:
377

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

 - The renamer renames it to a Name

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

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

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

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

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

454 455
  - 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
456
-}
457

458
-- | Located Declaration of a Type or Class
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
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnData',
467
    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',
Jan Stolarek's avatar
Jan Stolarek committed
468 469 470 471
    --             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP',
    --             'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP',
    --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow',
    --             'ApiAnnotation.AnnVbar'
Alan Zimmerman's avatar
Alan Zimmerman committed
472

473
    -- For details on above see note [Api annotations] in ApiAnnotation
474
    FamDecl { tcdFam :: FamilyDecl name }
475

476
  | -- | @type@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
477 478 479
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnEqual',
480 481

    -- For details on above see note [Api annotations] in ApiAnnotation
482 483
    SynDecl { tcdLName  :: Located name           -- ^ Type constructor
            , tcdTyVars :: LHsQTyVars name        -- ^ Type variables; for an associated type
484
                                                  --   these include outer binders
485
            , tcdRhs    :: LHsType name           -- ^ RHS of type declaration
486
            , tcdFVs    :: PostRn name NameSet }
487 488

  | -- | @data@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
489 490 491 492
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
    --              'ApiAnnotation.AnnFamily',
    --              'ApiAnnotation.AnnNewType',
493 494
    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'
    --              'ApiAnnotation.AnnWhere',
495 496

    -- For details on above see note [Api annotations] in ApiAnnotation
497
    DataDecl { tcdLName    :: Located name        -- ^ Type constructor
498
             , tcdTyVars   :: LHsQTyVars name  -- ^ Type variables; for an associated type
499
                                                  --   these include outer binders
500 501 502
                                                  -- Eg  class T a where
                                                  --       type F a :: *
                                                  --       type F a = a -> a
503
                                                  -- Here the type decl for 'f' includes 'a'
504
                                                  -- in its tcdTyVars
505
             , tcdDataDefn :: HsDataDefn name
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
506
             , tcdDataCusk :: PostRn name Bool    -- ^ does this have a CUSK?
507
             , tcdFVs      :: PostRn name NameSet }
508

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

528 529
        -- For details on above see note [Api annotations] in ApiAnnotation

530
deriving instance (DataId id) => Data (TyClDecl id)
531

532

Jan Stolarek's avatar
Jan Stolarek committed
533 534
-- Simple classifiers for TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535

536
-- | @True@ <=> argument is a @data@\/@newtype@
537 538
-- declaration.
isDataDecl :: TyClDecl name -> Bool
539 540
isDataDecl (DataDecl {}) = True
isDataDecl _other        = False
541

542 543
-- | type or type instance declaration
isSynDecl :: TyClDecl name -> Bool
544 545
isSynDecl (SynDecl {})   = True
isSynDecl _other        = False
546

547 548
-- | type class
isClassDecl :: TyClDecl name -> Bool
549
isClassDecl (ClassDecl {}) = True
550
isClassDecl _              = False
551

552
-- | type/data family declaration
553
isFamilyDecl :: TyClDecl name -> Bool
554
isFamilyDecl (FamDecl {})  = True
555
isFamilyDecl _other        = False
556 557 558

-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
559 560 561 562 563
isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
  OpenTypeFamily      -> True
  ClosedTypeFamily {} -> True
  _                   -> False
isTypeFamilyDecl _ = False
564

565 566 567 568 569 570 571 572 573 574
-- | 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

575 576
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
577
isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
578
isDataFamilyDecl _other      = False
579

Austin Seipp's avatar
Austin Seipp committed
580
-- Dealing with names
581

582
tyFamInstDeclName :: TyFamInstDecl name -> name
583 584
tyFamInstDeclName = unLoc . tyFamInstDeclLName

585
tyFamInstDeclLName :: TyFamInstDecl name -> Located name
586
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
587
                     (L _ (TyFamEqn { tfe_tycon = ln })) })
588 589 590 591 592
  = ln

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

594
tcdName :: TyClDecl name -> name
595 596
tcdName = unLoc . tyClDeclLName

597
tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name
598 599
tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
tyClDeclTyVars d = tcdTyVars d
600

601 602
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
        -- class, synonym decls, data, newtype, family decls
603
countTyClDecls decls
604 605 606 607
 = (count isClassDecl    decls,
    count isSynDecl      decls,  -- excluding...
    count isDataTy       decls,  -- ...family...
    count isNewTy        decls,  -- ...instances
608
    count isFamilyDecl   decls)
sof's avatar
sof committed
609
 where
610 611
   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
   isDataTy _                                                       = False
612

613 614
   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
   isNewTy _                                                      = False
615 616 617

-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [Complete user-supplied kind signatures]
618
hsDeclHasCusk :: TyClDecl Name -> Bool
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
619
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
620 621 622 623 624 625 626
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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
627
hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
628 629
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars

Jan Stolarek's avatar
Jan Stolarek committed
630 631
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
632

633
instance (OutputableBndrId name) => Outputable (TyClDecl name) where
634

635 636
    ppr (FamDecl { tcdFam = decl }) = ppr decl
    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
637
      = hang (text "type" <+>
638
              pp_vanilla_decl_head ltycon tyvars [] <+> equals)
639
          4 (ppr rhs)
640

641 642
    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
643

644
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
645
                    tcdFDs  = fds,
646 647 648
                    tcdSigs = sigs, tcdMeths = methods,
                    tcdATs = ats, tcdATDefs = at_defs})
      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
649 650
      = top_matter

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
651
      | otherwise       -- Laid out
652
      = vcat [ top_matter <+> text "where"
653
             , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++
654
                                     map ppr_fam_deflt_eqn at_defs ++
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
655
                                     pprLHsBindsForUser methods sigs) ]
656
      where
657
        top_matter = text "class"
658
                     <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
659
                     <+> pprFundeps (map unLoc fds)
660

661
instance (OutputableBndrId name) => Outputable (TyClGroup name) where
662 663 664 665 666
  ppr (TyClGroup { group_tyclds = tyclds
                 , group_roles = roles
                 , group_instds = instds
                 }
      )
667
    = ppr tyclds $$
668 669
      ppr roles $$
      ppr instds
670

671
pp_vanilla_decl_head :: (OutputableBndrId name)
Jan Stolarek's avatar
Jan Stolarek committed
672
   => Located name
673
   -> LHsQTyVars name
Jan Stolarek's avatar
Jan Stolarek committed
674 675 676 677 678 679
   -> HsContext name
   -> SDoc
pp_vanilla_decl_head thing tyvars context
 = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]

pprTyClDeclFlavour :: TyClDecl a -> SDoc
680 681
pprTyClDeclFlavour (ClassDecl {})   = text "class"
pprTyClDeclFlavour (SynDecl {})     = text "type"
Jan Stolarek's avatar
Jan Stolarek committed
682
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
683
  = pprFlavour info <+> text "family"
Jan Stolarek's avatar
Jan Stolarek committed
684 685 686 687
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
  = ppr nd


688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750
{- 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 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 *.

 - Additionally, if -XTypeInType is on, then a data definition with a top-level
   :: must explicitly bind all kind variables to the right of the ::.
   See test dependent/should_compile/KindLevels, which requires this case.
   (Naturally, any kind variable mentioned before the :: should not be bound
   after it.)
-}


{- *********************************************************************
*                                                                      *
                         TyClGroup
        Strongly connected components of
      type, class, instance, and role declarations
*                                                                      *
********************************************************************* -}

{- Note [TyClGroups and dependency analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A TyClGroup represents a strongly connected components of type/class/instance
decls, together with the role annotations for the type/class declarations.

The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order
sequence of strongly-connected components.

Invariants
 * The type and class declarations, group_tyclds, may depend on each
   other, or earlier TyClGroups, but not on later ones

 * The role annotations, group_roles, are role-annotations for some or
   all of the types and classes in group_tyclds (only).

 * The instance declarations, group_instds, may (and usually will)
   depend on group_tyclds, or on earlier TyClGroups, but not on later
   ones.

See Note [Dependency analsis of type, class, and instance decls]
in RnSource for more info.
-}

751
-- | Type or Class Group
752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
data TyClGroup name  -- See Note [TyClGroups and dependency analysis]
  = TyClGroup { group_tyclds :: [LTyClDecl name]
              , group_roles  :: [LRoleAnnotDecl name]
              , group_instds :: [LInstDecl name] }
deriving instance (DataId id) => Data (TyClGroup id)

emptyTyClGroup :: TyClGroup name
emptyTyClGroup = TyClGroup [] [] []

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

tyClGroupInstDecls :: [TyClGroup name] -> [LInstDecl name]
tyClGroupInstDecls = concatMap group_instds

tyClGroupRoleDecls :: [TyClGroup name] -> [LRoleAnnotDecl name]
tyClGroupRoleDecls = concatMap group_roles

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



Jan Stolarek's avatar
Jan Stolarek committed
779 780 781 782 783 784
{- *********************************************************************
*                                                                      *
               Data and type family declarations
*                                                                      *
********************************************************************* -}

785 786
{- Note [FamilyResultSig]
~~~~~~~~~~~~~~~~~~~~~~~~~
Jan Stolarek's avatar
Jan Stolarek committed
787

788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846
This data type represents the return signature of a type family.  Possible
values are:

 * NoSig - the user supplied no return signature:
      type family Id a where ...

 * KindSig - the user supplied the return kind:
      type family Id a :: * where ...

 * TyVarSig - user named the result with a type variable and possibly
   provided a kind signature for that variable:
      type family Id a = r where ...
      type family Id a = (r :: *) where ...

   Naming result of a type family is required if we want to provide
   injectivity annotation for a type family:
      type family Id a = r | r -> a where ...

See also: Note [Injectivity annotation]

Note [Injectivity annotation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A user can declare a type family to be injective:

   type family Id a = r | r -> a where ...

 * The part after the "|" is called "injectivity annotation".
 * "r -> a" part is called "injectivity condition"; at the moment terms
   "injectivity annotation" and "injectivity condition" are synonymous
   because we only allow a single injectivity condition.
 * "r" is the "LHS of injectivity condition". LHS can only contain the
   variable naming the result of a type family.

 * "a" is the "RHS of injectivity condition". RHS contains space-separated
   type and kind variables representing the arguments of a type
   family. Variables can be omitted if a type family is not injective in
   these arguments. Example:
         type family Foo a b c = d | d -> a c where ...

Note that:
 (a) naming of type family result is required to provide injectivity
     annotation
 (b) for associated types if the result was named then injectivity annotation
     is mandatory. Otherwise result type variable is indistinguishable from
     associated type default.

It is possible that in the future this syntax will be extended to support
more complicated injectivity annotations. For example we could declare that
if we know the result of Plus and one of its arguments we can determine the
other argument:

   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...

Here injectivity annotation would consist of two comma-separated injectivity
conditions.

See also Note [Injective type families] in TyCon
-}
Jan Stolarek's avatar
Jan Stolarek committed
847

848
-- | Located type Family Result Signature
Jan Stolarek's avatar
Jan Stolarek committed
849
type LFamilyResultSig name = Located (FamilyResultSig name)
850 851

-- | type Family Result Signature
Jan Stolarek's avatar
Jan Stolarek committed
852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873
data FamilyResultSig name = -- see Note [FamilyResultSig]
    NoSig
  -- ^ - 'ApiAnnotation.AnnKeywordId' :

  -- For details on above see note [Api annotations] in ApiAnnotation

  | KindSig  (LHsKind name)
  -- ^ - 'ApiAnnotation.AnnKeywordId' :
  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
  --             'ApiAnnotation.AnnCloseP'

  -- For details on above see note [Api annotations] in ApiAnnotation

  | TyVarSig (LHsTyVarBndr name)
  -- ^ - 'ApiAnnotation.AnnKeywordId' :
  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
  --             'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'

  -- For details on above see note [Api annotations] in ApiAnnotation

deriving instance (DataId name) => Data (FamilyResultSig name)

874
-- | Located type Family Declaration
Jan Stolarek's avatar
Jan Stolarek committed
875
type LFamilyDecl name = Located (FamilyDecl name)
876 877

-- | type Family Declaration
Jan Stolarek's avatar
Jan Stolarek committed
878 879 880
data FamilyDecl name = FamilyDecl
  { fdInfo           :: FamilyInfo name              -- type/data, closed/open
  , fdLName          :: Located name                 -- type constructor
881
  , fdTyVars         :: LHsQTyVars name              -- type variables
Jan Stolarek's avatar
Jan Stolarek committed
882 883 884 885 886 887 888 889 890 891 892 893 894 895
  , fdResultSig      :: LFamilyResultSig name        -- result signature
  , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann
  }
  -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
  --             'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',
  --             'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',
  --             'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP',
  --             'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow',
  --             'ApiAnnotation.AnnVbar'

  -- For details on above see note [Api annotations] in ApiAnnotation

deriving instance (DataId id) => Data (FamilyDecl id)

896
-- | Located Injectivity Annotation
Jan Stolarek's avatar
Jan Stolarek committed
897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912
type LInjectivityAnn name = Located (InjectivityAnn name)

-- | If the user supplied an injectivity annotation it is represented using
-- InjectivityAnn. At the moment this is a single injectivity condition - see
-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity
-- condition. `[Located name]` stores the RHS of injectivity condition. Example:
--
--   type family Foo a b c = r | r -> a c where ...
--
-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
data InjectivityAnn name
  = InjectivityAnn (Located name) [Located name]
  -- ^ - 'ApiAnnotation.AnnKeywordId' :
  --             'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'

  -- For details on above see note [Api annotations] in ApiAnnotation
913
  deriving Data
Jan Stolarek's avatar
Jan Stolarek committed
914 915 916 917 918 919 920 921 922 923

data FamilyInfo name
  = DataFamily
  | OpenTypeFamily
     -- | 'Nothing' if we're in an hs-boot file and the user
     -- said "type family Foo x where .."
  | ClosedTypeFamily (Maybe [LTyFamInstEqn name])
deriving instance (DataId name) => Data (FamilyInfo name)

-- | Does this family declaration have a complete, user-supplied kind signature?
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
924 925 926 927 928 929
famDeclHasCusk :: Maybe Bool
                   -- ^ if associated, does the enclosing class have a CUSK?
               -> FamilyDecl name -> Bool
famDeclHasCusk _ (FamilyDecl { fdInfo      = ClosedTypeFamily _
                             , fdTyVars    = tyvars
                             , fdResultSig = L _ resultSig })
Jan Stolarek's avatar
Jan Stolarek committed
930
  = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
931 932
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
        -- all un-associated open families have CUSKs!