HsDecls.hs 75.3 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 100
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId )
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
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
131 132
  = TyClD       (TyClDecl id)     -- ^ A type or class declaration.
  | InstD       (InstDecl  id)    -- ^ An instance declaration.
133
  | DerivD      (DerivDecl id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
134 135 136
  | ValD        (HsBind id)
  | SigD        (Sig id)
  | DefD        (DefaultDecl id)
137
  | ForD        (ForeignDecl id)
Alan Zimmerman's avatar
Alan Zimmerman committed
138
  | WarningD    (WarnDecls id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
139
  | AnnD        (AnnDecl id)
Alan Zimmerman's avatar
Alan Zimmerman committed
140
  | RuleD       (RuleDecls id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
141
  | VectD       (VectDecl id)
142
  | SpliceD     (SpliceDecl id)   -- Includes quasi-quotes
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
143
  | DocD        (DocDecl)
144
  | RoleAnnotD  (RoleAnnotDecl id)
145
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],
169 170
                -- 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
171 172
                -- Parser generates a singleton list;
                -- renamer does dependency analysis
173

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
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
Alan Zimmerman's avatar
Alan Zimmerman committed
182
        hs_warnds :: [LWarnDecls id],
183
        hs_annds  :: [LAnnDecl id],
Alan Zimmerman's avatar
Alan Zimmerman committed
184
        hs_ruleds :: [LRuleDecls id],
185
        hs_vects  :: [LVectDecl id],
186

187
        hs_docs   :: [LDocDecl]
188
  }
189
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 196 197 198
hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
hsGroupInstDecls = (=<<) group_instds . hs_tyclds

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

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

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

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

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

instance OutputableBndr name => Outputable (SpliceDecl name) where
311
   ppr (SpliceDecl (L _ e) _) = pprSplice e
312

Austin Seipp's avatar
Austin Seipp committed
313 314 315
{-
************************************************************************
*                                                                      *
316
            Type and class declarations
Austin Seipp's avatar
Austin Seipp committed
317 318
*                                                                      *
************************************************************************
319

320 321
Note [The Naming story]
~~~~~~~~~~~~~~~~~~~~~~~
322 323
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
324 325 326

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

336 337
All have occurrence names that are derived uniquely from their parent
declaration.
338 339 340 341 342 343 344

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:
345
 - Ensure they "point to" the parent data/class decl
346
   when loading that decl from an interface file
347 348 349 350 351
   (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
352

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

356 357 358 359 360 361
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
362 363
   the ClassOpSig (in HsBinds), in the DefMethInfo field.
   (DefMethInfo is defined in Class.hs)
364 365 366 367 368 369 370

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

372 373 374 375 376
 - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
   This is done by RdrHsSyn.mkClassOpSigDM

 - The renamer renames it to a Name

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

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

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

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

437
  - We can take this relaxed approach (changing the occurrence name later)
438 439 440 441 442 443 444 445 446
    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.
447

448 449
  - 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
450
-}
451

452 453
type LTyClDecl name = Located (TyClDecl name)

454
-- | A type or class declaration.
455
data TyClDecl name
Yuras's avatar
Yuras committed
456
  = -- | @type/data family T :: *->*@
Alan Zimmerman's avatar
Alan Zimmerman committed
457 458 459
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnData',
460
    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',
Jan Stolarek's avatar
Jan Stolarek committed
461 462 463 464
    --             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP',
    --             'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP',
    --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow',
    --             'ApiAnnotation.AnnVbar'
Alan Zimmerman's avatar
Alan Zimmerman committed
465

466
    -- For details on above see note [Api annotations] in ApiAnnotation
467
    FamDecl { tcdFam :: FamilyDecl name }
468

469
  | -- | @type@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
470 471 472
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
    --             'ApiAnnotation.AnnEqual',
473 474

    -- For details on above see note [Api annotations] in ApiAnnotation
475 476
    SynDecl { tcdLName  :: Located name           -- ^ Type constructor
            , tcdTyVars :: LHsQTyVars name        -- ^ Type variables; for an associated type
477
                                                  --   these include outer binders
478
            , tcdRhs    :: LHsType name           -- ^ RHS of type declaration
479
            , tcdFVs    :: PostRn name NameSet }
480 481

  | -- | @data@ declaration
Alan Zimmerman's avatar
Alan Zimmerman committed
482 483 484 485
    --
    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
    --              'ApiAnnotation.AnnFamily',
    --              'ApiAnnotation.AnnNewType',
486 487
    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'
    --              'ApiAnnotation.AnnWhere',
488 489

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

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

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

523
deriving instance (DataId id) => Data (TyClDecl id)
524

525

Jan Stolarek's avatar
Jan Stolarek committed
526 527
-- Simple classifiers for TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
528

529
-- | @True@ <=> argument is a @data@\/@newtype@
530 531
-- declaration.
isDataDecl :: TyClDecl name -> Bool
532 533
isDataDecl (DataDecl {}) = True
isDataDecl _other        = False
534

535 536
-- | type or type instance declaration
isSynDecl :: TyClDecl name -> Bool
537 538
isSynDecl (SynDecl {})   = True
isSynDecl _other        = False
539

540 541
-- | type class
isClassDecl :: TyClDecl name -> Bool
542
isClassDecl (ClassDecl {}) = True
543
isClassDecl _              = False
544

545
-- | type/data family declaration
546
isFamilyDecl :: TyClDecl name -> Bool
547
isFamilyDecl (FamDecl {})  = True
548
isFamilyDecl _other        = False
549 550 551

-- | type family declaration
isTypeFamilyDecl :: TyClDecl name -> Bool
552 553 554 555 556
isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
  OpenTypeFamily      -> True
  ClosedTypeFamily {} -> True
  _                   -> False
isTypeFamilyDecl _ = False
557

558 559 560 561 562 563 564 565 566 567
-- | 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

568 569
-- | data family declaration
isDataFamilyDecl :: TyClDecl name -> Bool
570
isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
571
isDataFamilyDecl _other      = False
572

Austin Seipp's avatar
Austin Seipp committed
573
-- Dealing with names
574

575
tyFamInstDeclName :: TyFamInstDecl name -> name
576 577
tyFamInstDeclName = unLoc . tyFamInstDeclLName

578
tyFamInstDeclLName :: TyFamInstDecl name -> Located name
579
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
580
                     (L _ (TyFamEqn { tfe_tycon = ln })) })
581 582 583 584 585
  = ln

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

587
tcdName :: TyClDecl name -> name
588 589
tcdName = unLoc . tyClDeclLName

590
tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name
591 592
tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
tyClDeclTyVars d = tcdTyVars d
593

594 595
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
        -- class, synonym decls, data, newtype, family decls
596
countTyClDecls decls
597 598 599 600
 = (count isClassDecl    decls,
    count isSynDecl      decls,  -- excluding...
    count isDataTy       decls,  -- ...family...
    count isNewTy        decls,  -- ...instances
601
    count isFamilyDecl   decls)
sof's avatar
sof committed
602
 where
603 604
   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
   isDataTy _                                                       = False
605

606 607
   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
   isNewTy _                                                      = False
608 609 610

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

Jan Stolarek's avatar
Jan Stolarek committed
623 624
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
625

626
instance OutputableBndr name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
627
              => Outputable (TyClDecl name) where
628

629 630
    ppr (FamDecl { tcdFam = decl }) = ppr decl
    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
631
      = hang (text "type" <+>
632
              pp_vanilla_decl_head ltycon tyvars [] <+> equals)
633
          4 (ppr rhs)
634

635 636
    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
637

638
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
639
                    tcdFDs  = fds,
640 641 642
                    tcdSigs = sigs, tcdMeths = methods,
                    tcdATs = ats, tcdATDefs = at_defs})
      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
643 644
      = top_matter

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

655
instance OutputableBndr name => Outputable (TyClGroup name) where
656 657 658 659 660
  ppr (TyClGroup { group_tyclds = tyclds
                 , group_roles = roles
                 , group_instds = instds
                 }
      )
661
    = ppr tyclds $$
662 663
      ppr roles $$
      ppr instds
664

Jan Stolarek's avatar
Jan Stolarek committed
665 666
pp_vanilla_decl_head :: OutputableBndr name
   => Located name
667
   -> LHsQTyVars name
Jan Stolarek's avatar
Jan Stolarek committed
668 669 670 671 672 673
   -> HsContext name
   -> SDoc
pp_vanilla_decl_head thing tyvars context
 = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]

pprTyClDeclFlavour :: TyClDecl a -> SDoc
674 675
pprTyClDeclFlavour (ClassDecl {})   = text "class"
pprTyClDeclFlavour (SynDecl {})     = text "type"
Jan Stolarek's avatar
Jan Stolarek committed
676
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
677
  = pprFlavour info <+> text "family"
Jan Stolarek's avatar
Jan Stolarek committed
678 679 680 681
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
  = ppr nd


682 683 684 685 686 687 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 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771
{- 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.
-}

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
772 773 774 775 776 777
{- *********************************************************************
*                                                                      *
               Data and type family declarations
*                                                                      *
********************************************************************* -}

778 779
{- Note [FamilyResultSig]
~~~~~~~~~~~~~~~~~~~~~~~~~
Jan Stolarek's avatar
Jan Stolarek committed
780

781 782 783 784 785 786 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
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
840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867

type LFamilyResultSig name = Located (FamilyResultSig name)
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)

type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
  { fdInfo           :: FamilyInfo name              -- type/data, closed/open
  , fdLName          :: Located name                 -- type constructor
868
  , fdTyVars         :: LHsQTyVars name              -- type variables
Jan Stolarek's avatar
Jan Stolarek committed
869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898
  , 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)

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
899
  deriving Data
Jan Stolarek's avatar
Jan Stolarek committed
900 901 902 903 904 905 906 907 908 909

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
910 911 912 913 914 915
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
916
  = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
917 918
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
        -- all un-associated open families have CUSKs!
Jan Stolarek's avatar
Jan Stolarek committed
919 920 921 922 923 924 925 926 927 928 929 930

-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
hasReturnKindSignature NoSig                          = False
hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
hasReturnKindSignature _                              = True

-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig a -> Maybe a
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _              = Nothing

931
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
  ppr = pprFamilyDecl TopLevel

pprFamilyDecl :: OutputableBndr name => TopLevelFlag -> FamilyDecl name -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                                    , fdTyVars = tyvars
                                    , fdResultSig = L _ result
                                    , fdInjectivityAnn = mb_inj })
  = vcat [ pprFlavour info <+> pp_top_level <+>
           pp_vanilla_decl_head ltycon tyvars [] <+>
           pp_kind <+> pp_inj <+> pp_where
         , nest 2 $ pp_eqns ]
  where
    pp_top_level = case top_level of
                     TopLevel    -> text "family"
                     NotTopLevel -> empty

    pp_kind = case result of
                NoSig            -> empty