HsDecls.lhs 60.1 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5

6
\begin{code}
7 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 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
  HsDecl(..), LHsDecl, HsDataDefn(..),
22
  -- ** Class or type declarations
23 24
  TyClDecl(..), LTyClDecl,
  TyClGroup(..), tyClGroupConcat, mkTyClGroup,
25 26
  isClassDecl, isDataDecl, isSynDecl, tcdName,
  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
27
  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
28 29 30
  tyFamInstDeclName, tyFamInstDeclLName,
  countTyClDecls, pprTyClDeclFlavour,
  tyClDeclLName, tyClDeclTyVars,
31
  hsDeclHasCusk, famDeclHasCusk,
32
  FamilyDecl(..), LFamilyDecl,
33

34
  -- ** Instance declarations
35
  InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
36 37
  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
38
  TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
39
  LClsInstDecl, ClsInstDecl(..),
40

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

  -- * Grouping
71
  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
72

73
    ) where
74 75

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

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

-- others:
92
import InstEnv
93
import Class
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
94
import Outputable       
95 96
import Util
import SrcLoc
rrt's avatar
rrt committed
97
import FastString
98

99
import Bag
100
import Data.Data        hiding (TyCon,Fixity)
101 102
import Data.Foldable (Foldable)
import Data.Traversable
103
import Data.Maybe
104 105
\end{code}

106
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
107
%*                                                                      *
108
\subsection[HsDecl]{Declarations}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
109
%*                                                                      *
110 111 112
%************************************************************************

\begin{code}
113 114
type LHsDecl id = Located (HsDecl id)

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

135 136

-- NB: all top-level fixity decls are contained EITHER
137
-- EITHER SigDs
138 139 140
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
141 142 143 144 145
--      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
146 147
--
-- The latter is for class methods only
148

149
-- | A 'HsDecl' is categorised into a 'HsGroup' before being
150 151 152
-- fed to the renamer.
data HsGroup id
  = HsGroup {
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
153
        hs_valds  :: HsValBinds id,
154
        hs_splcds :: [LSpliceDecl id],
155

156
        hs_tyclds :: [TyClGroup id],
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
157
                -- A list of mutually-recursive groups
158
                -- No family-instances here; they are in hs_instds
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
159 160
                -- Parser generates a singleton list;
                -- renamer does dependency analysis
161

162 163 164
        hs_instds  :: [LInstDecl id],
                -- Both class and family instance declarations in here

165
        hs_derivds :: [LDerivDecl id],
166

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

171 172 173 174 175 176
        hs_defds  :: [LDefaultDecl id],
        hs_fords  :: [LForeignDecl id],
        hs_warnds :: [LWarnDecl id],
        hs_annds  :: [LAnnDecl id],
        hs_ruleds :: [LRuleDecl id],
        hs_vects  :: [LVectDecl id],
177

178
        hs_docs   :: [LDocDecl]
179 180
  } deriving (Typeable)
deriving instance (DataId id) => Data (HsGroup id)
181

182 183 184 185
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }

186 187
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], 
                       hs_derivds = [],
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
188 189 190
                       hs_fixds = [], hs_defds = [], hs_annds = [],
                       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
                       hs_valds = error "emptyGroup hs_valds: Can't happen",
191
                       hs_splcds = [],
192
                       hs_docs = [] }
193 194 195 196

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

\begin{code}
242
instance OutputableBndr name => Outputable (HsDecl name) where
243 244 245 246 247 248 249 250
    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
251
    ppr (VectD vect)            = ppr vect
Ian Lynagh's avatar
Ian Lynagh committed
252
    ppr (WarningD wd)           = ppr wd
253
    ppr (AnnD ad)               = ppr ad
254 255
    ppr (SpliceD dd)            = ppr dd
    ppr (DocD doc)              = ppr doc
256
    ppr (QuasiQuoteD qq)        = ppr qq
257
    ppr (RoleAnnotD ra)         = ppr ra
258 259 260

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
261 262
                   hs_tyclds = tycl_decls,
                   hs_instds = inst_decls,
263
                   hs_derivds = deriv_decls,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
264 265 266 267 268 269 270 271
                   hs_fixds  = fix_decls,
                   hs_warnds = deprec_decls,
                   hs_annds  = ann_decls,
                   hs_fords  = foreign_decls,
                   hs_defds  = default_decls,
                   hs_ruleds = rule_decls,
                   hs_vects  = vect_decls })
        = vcat_mb empty 
272
            [ppr_ds fix_decls, ppr_ds default_decls, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
273 274 275 276
             ppr_ds deprec_decls, ppr_ds ann_decls,
             ppr_ds rule_decls,
             ppr_ds vect_decls,
             if isEmptyValBinds val_decls 
277 278
                then Nothing 
                else Just (ppr val_decls),
279
             ppr_ds (tyClGroupConcat tycl_decls), 
280
             ppr_ds inst_decls,
281
             ppr_ds deriv_decls,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
282 283
             ppr_ds foreign_decls]
        where
284
          ppr_ds :: Outputable a => [a] -> Maybe SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
285 286
          ppr_ds [] = Nothing
          ppr_ds ds = Just (vcat (map ppr ds))
287 288

          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
289
          -- Concatenate vertically with white-space between non-blanks
290 291 292
          vcat_mb _    []             = empty
          vcat_mb gap (Nothing : ds) = vcat_mb gap ds
          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
293

294
type LSpliceDecl name = Located (SpliceDecl name)
295
data SpliceDecl id
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
296
  = SpliceDecl                  -- Top level splice
297
        (Located (HsSplice id))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
298 299
        HsExplicitFlag          -- Explicit <=> $(f x y)
                                -- Implicit <=> f x y,  i.e. a naked top level expression
300 301
    deriving (Typeable)
deriving instance (DataId id) => Data (SpliceDecl id)
302 303

instance OutputableBndr name => Outputable (SpliceDecl name) where
304
   ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
305 306
\end{code}

307

308
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
309
%*                                                                      *
310
\subsection[SynDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
311
%*                                                                      *
312 313
%************************************************************************

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
314 315 316
                --------------------------------
                        THE NAMING STORY
                --------------------------------
317

318 319
Here is the story about the implicit names that go with type, class,
and instance decls.  It's a bit tricky, so pay attention!
320 321 322

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

332 333
All have occurrence names that are derived uniquely from their parent
declaration.
334 335 336 337 338 339 340 341 342

None of these get separate definitions in an interface file; they are
fully defined by the data or class decl.  But they may *occur* in
interface files, of course.  Any such occurrence must haul in the
relevant type or class decl.

Plan of attack:
 - Ensure they "point to" the parent data/class decl 
   when loading that decl from an interface file
343 344 345 346 347
   (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
348

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

352 353 354 355 356 357 358 359 360 361 362 363 364 365 366
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:
367

368 369 370 371 372 373 374
 - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
   This is done by RdrHsSyn.mkClassOpSigDM

 - The renamer renames it to a Name

 - During typechecking, we generate a binding for each $dm for 
   which there's a programmer-supplied default method:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
375 376 377 378
        class Foo a where
          op1 :: <type>
          op2 :: <type>
          op1 = ...
379 380 381 382 383 384 385
   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
386 387 388
        class Foo a where
          op1 = :: <type>       -- NB the '='
          op2   :: <type>
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
    We use this info to generate a DefMeth with a suitable RdrName for op1,
    and a NoDefMeth for op2
  - The interface file has a separate definition for $dmop1, with unfolding etc.
  - The renamer renames it to a Name.
  - The renamer treats $dmop1 as a free variable of the declaration, so that
    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)  
    This doesn't happen for source code class decls, because they *bind* the default method.

Dictionary functions
~~~~~~~~~~~~~~~~~~~~
Each instance declaration gives rise to one dictionary function binding.

The type checker makes up new source-code instance declarations
(e.g. from 'deriving' or generic default methods --- see
TcInstDcls.tcInstDecls1).  So we can't generate the names for
dictionary functions in advance (we don't know how many we need).

On the other hand for interface-file instance declarations, the decl
specifies the name of the dictionary function, and it has a binding elsewhere
in the interface file:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
409 410
        instance {Eq Int} = dEqInt
        dEqInt :: {Eq Int} <pragma info>
411 412 413 414 415 416 417 418 419 420 421 422 423 424

So again we treat source code and interface file code slightly differently.

Source code:
  - Source code instance decls have a Nothing in the (Maybe name) field
    (see data InstDecl below)

  - The typechecker makes up a Local name for the dict fun for any source-code
    instance decl, whether it comes from a source-code instance decl, or whether
    the instance decl is derived from some other construct (e.g. 'deriving').

  - The occurrence name it chooses is derived from the instance decl (just for 
    documentation really) --- e.g. dNumInt.  Two dict funs may share a common
    occurrence name, but will have different uniques.  E.g.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
425 426
        instance Foo [Int]  where ...
        instance Foo [Bool] where ...
427 428
    These might both be dFooList

429
  - The CoreTidy phase externalises the name, and ensures the occurrence name is
430 431 432 433 434 435 436 437 438 439 440 441
    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.

  - We can take this relaxed approach (changing the occurrence name later) 
    because dict fun Ids are not captured in a TyCon or Class (unlike default
    methods, say).  Instead, they are kept separately in the InstEnv.  This
    makes it easy to adjust them after compiling a module.  (Once we've finished
    compiling that module, they don't change any more.)


Interface file code:
  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
    in the (Maybe name) field.
442

443 444
  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
    suck in the dfun binding
445 446


447
\begin{code}
448 449
type LTyClDecl name = Located (TyClDecl name)

450
-- | A type or class declaration.
451
data TyClDecl name
452
  = ForeignType { 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
453 454
                tcdLName    :: Located name,
                tcdExtName  :: Maybe FastString
455 456
    }

457
  | -- | @type/data family T :: *->*@
458
    FamDecl { tcdFam :: FamilyDecl name }
459

460 461
  | -- | @type@ declaration
    SynDecl { tcdLName  :: Located name            -- ^ Type constructor
462
            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
463
                                                  --   these include outer binders
464
            , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
465
            , tcdFVs    :: PostRn name NameSet }
466 467 468 469 470

  | -- | @data@ declaration
    DataDecl { tcdLName    :: Located name        -- ^ Type constructor
             , tcdTyVars   :: LHsTyVarBndrs name  -- ^ Type variables; for an assoicated type
                                                  --   these include outer binders
471 472 473 474 475
                                                  -- Eg  class T a where
                                                  --       type F a :: *
                                                  --       type F a = a -> a
                                                  -- Here the type decl for 'f' includes 'a' 
                                                  -- in its tcdTyVars
476
             , tcdDataDefn :: HsDataDefn name
477
             , tcdFVs      :: PostRn name NameSet }
478

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
479 480
  | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                tcdLName   :: Located name,             -- ^ Name of the class
481
                tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
482 483 484
                tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
                tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                tcdMeths   :: LHsBinds name,            -- ^ Default methods
485
                tcdATs     :: [LFamilyDecl name],       -- ^ Associated types; ie
486
                tcdATDefs  :: [LTyFamDefltEqn name],    -- ^ Associated type defaults
487
                tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
488
                tcdFVs     :: PostRn name NameSet
489
    }
490 491 492

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

494 495 496 497 498 499 500 501
 -- 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] }
502 503
    deriving (Typeable)
deriving instance (DataId id) => Data (TyClGroup id)
504 505 506 507 508 509 510

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

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

511 512
type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
513
  { fdInfo    :: FamilyInfo name            -- type or data, closed or open
514 515 516
  , fdLName   :: Located name               -- type constructor
  , fdTyVars  :: LHsTyVarBndrs name         -- type variables
  , fdKindSig :: Maybe (LHsKind name) }     -- result kind
517 518
  deriving( Typeable )
deriving instance (DataId id) => Data (FamilyDecl id)
519

520 521 522
data FamilyInfo name
  = DataFamily
  | OpenTypeFamily
523 524
     -- this list might be empty, if we're in an hs-boot file and the user
     -- said "type family Foo x where .."
525
  | ClosedTypeFamily [LTyFamInstEqn name]
526 527
  deriving( Typeable )
deriving instance (DataId name) => Data (FamilyInfo name)
dreixel's avatar
dreixel committed
528

529
\end{code}
530 531

------------------------------
532 533 534
Simple classifiers

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

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

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

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

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

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

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

579 580 581
\end{code}

Dealing with names
582

583
\begin{code}
584 585 586 587 588 589
tyFamInstDeclName :: OutputableBndr name
                  => TyFamInstDecl name -> name
tyFamInstDeclName = unLoc . tyFamInstDeclLName

tyFamInstDeclLName :: OutputableBndr name
                   => TyFamInstDecl name -> Located name
590
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
591
                     (L _ (TyFamEqn { tfe_tycon = ln })) })
592 593 594 595 596
  = ln

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

598
tcdName :: TyClDecl name -> name
599 600 601 602 603 604
tcdName = unLoc . tyClDeclLName

tyClDeclTyVars :: OutputableBndr name => TyClDecl name -> LHsTyVarBndrs name
tyClDeclTyVars decl@(ForeignType {}) = pprPanic "tyClDeclTyVars" (ppr decl)
tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
tyClDeclTyVars d = tcdTyVars d
605 606 607
\end{code}

\begin{code}
608 609
countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
        -- class, synonym decls, data, newtype, family decls
610
countTyClDecls decls 
611 612 613 614
 = (count isClassDecl    decls,
    count isSynDecl      decls,  -- excluding...
    count isDataTy       decls,  -- ...family...
    count isNewTy        decls,  -- ...instances
615
    count isFamilyDecl   decls)
sof's avatar
sof committed
616
 where
617 618
   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True
   isDataTy _                                                       = False
sof's avatar
sof committed
619
   
620 621
   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True
   isNewTy _                                                      = False
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644

-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [Complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl name -> Bool
hsDeclHasCusk (ForeignType {}) = True
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!
645 646
\end{code}

647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669
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 *.

670
\begin{code}
671
instance OutputableBndr name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
672
              => Outputable (TyClDecl name) where
673

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

677 678 679 680 681
    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)
          4 (ppr rhs) 
682

683 684
    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
685

686
    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
687
                    tcdFDs  = fds,
688 689 690
                    tcdSigs = sigs, tcdMeths = methods,
                    tcdATs = ats, tcdATDefs = at_defs})
      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part
691 692
      = top_matter

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
693
      | otherwise       -- Laid out
694
      = vcat [ top_matter <+> ptext (sLit "where")
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
695
             , nest 2 $ pprDeclList (map ppr ats ++
696
                                     map ppr_fam_deflt_eqn at_defs ++
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
697
                                     pprLHsBindsForUser methods sigs) ]
698
      where
699
        top_matter = ptext (sLit "class") 
700
                     <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
701
                     <+> pprFundeps (map unLoc fds)
702

703 704 705 706 707
instance OutputableBndr name => Outputable (TyClGroup name) where
  ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
    = ppr tyclds $$
      ppr roles

708
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
709
  ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, 
710
                    fdTyVars = tyvars, fdKindSig = mb_kind})
711 712
      = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
             , nest 2 $ pp_eqns ]
713 714 715 716
        where
          pp_kind = case mb_kind of
                      Nothing   -> empty
                      Just kind -> dcolon <+> ppr kind
717 718
          (pp_where, pp_eqns) = case info of
            ClosedTypeFamily eqns -> ( ptext (sLit "where")
719 720
                                     , if null eqns
                                       then ptext (sLit "..")
721
                                       else vcat $ map ppr_fam_inst_eqn eqns )
722 723 724 725 726 727
            _                     -> (empty, empty)

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

729 730
instance Outputable (FamilyInfo name) where
  ppr = pprFlavour
731

732 733
pp_vanilla_decl_head :: OutputableBndr name
   => Located name
734
   -> LHsTyVarBndrs name
735 736 737
   -> HsContext name
   -> SDoc
pp_vanilla_decl_head thing tyvars context
738
 = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
739

740
pp_fam_inst_lhs :: OutputableBndr name
741
   => Located name
742
   -> HsTyPats name
743
   -> HsContext name
744
   -> SDoc
745 746
pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
   = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
747
          , hsep (map (pprParendHsType.unLoc) typats)]
748

749
pprTyClDeclFlavour :: TyClDecl a -> SDoc
750 751
pprTyClDeclFlavour (ClassDecl {})   = ptext (sLit "class")
pprTyClDeclFlavour (SynDecl {})     = ptext (sLit "type")
752
pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
753 754 755 756
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
  = pprFlavour info
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
  = ppr nd
757 758 759
\end{code}

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
760
%*                                                                      *
761
\subsection[ConDecl]{A data-constructor declaration}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
762
%*                                                                      *
763 764 765
%************************************************************************

\begin{code}
766 767 768 769

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
770
  = -- | Declares a data type or newtype, giving its constructors
771 772 773 774 775 776 777 778 779 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
    -- @
    --  data/newtype T a = <constrs>
    --  data/newtype instance T [a] = <constrs>
    -- @
    HsDataDefn { dd_ND     :: NewOrData,
                 dd_ctxt   :: LHsContext name,           -- ^ Context
                 dd_cType  :: Maybe CType,
                 dd_kindSig:: Maybe (LHsKind name),
                     -- ^ Optional kind signature.
                     --
                     -- @(Just k)@ for a GADT-style @data@, 
                     -- 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'.

                 dd_derivs :: Maybe [LHsType name]
                     -- ^ 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
    }
805 806
    deriving( Typeable )
deriving instance (DataId id) => Data (HsDataDefn id)
807 808 809 810 811 812

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

813 814
type LConDecl name = Located (ConDecl name)

815 816 817 818
-- data T b = forall a. Eq a => MkT a b
--   MkT :: forall b a. Eq a => MkT a b

-- data T b where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
819
--      MkT1 :: Int -> T Int
820 821

-- data T = Int `MkT` Int
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
822
--        | MkT2
823 824

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

827
data ConDecl name
828
  = ConDecl
829 830 831
    { con_name      :: Located name
        -- ^ Constructor name.  This is used for the DataCon itself, and for
        -- the user-callable wrapper Id.
832

833
    , con_explicit  :: HsExplicitFlag
834
        -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
835

836
    , con_qvars     :: LHsTyVarBndrs name
837
        -- ^ Type variables.  Depending on 'con_res' this describes the
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
838
        -- following entities
839
        --
840 841
        --  - ResTyH98:  the constructor's *existential* type variables
        --  - ResTyGADT: *all* the constructor's quantified type variables
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
842 843 844
        --
        -- If con_explicit is Implicit, then con_qvars is irrelevant
        -- until after renaming.  
845

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

850 851
    , con_details   :: HsConDeclDetails name
        -- ^ The main payload
852

853
    , con_res       :: ResType (LHsType name)
854
        -- ^ Result type of the constructor
855

856
    , con_doc       :: Maybe LHsDocString
857
        -- ^ A possible Haddock comment.
858

859
    , con_old_rec :: Bool
860
        -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
861 862 863
        --                             GADT-style record decl   C { blah } :: T a b
        -- Remove this when we no longer parse this stuff, and hence do not
        -- need to report decprecated use
864 865
    } deriving (Typeable)
deriving instance (DataId name) => Data (ConDecl name)
866

867 868 869 870 871 872 873
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]

hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys)    = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds)      = map cd_fld_type flds

874
data ResType ty
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
875
   = ResTyH98           -- Constructor was declared using Haskell 98 syntax
876 877
   | ResTyGADT ty       -- Constructor was declared using GADT-style syntax,
                        --      and here is its result type
878
   deriving (Data, Typeable)
879

880
instance Outputable ty => Outputable (ResType ty) where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
881
         -- Debugging only
882 883
   ppr ResTyH98       = ptext (sLit "ResTyH98")
   ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty
884 885
\end{code}

886 887

\begin{code}
888 889 890 891 892
pp_data_defn :: OutputableBndr name
                  => (HsContext name -> SDoc)   -- Printing the header
                  -> HsDataDefn name
                  -> SDoc 
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
893 894
                                , dd_kindSig = mb_sig 
                                , dd_cons = condecls, dd_derivs = derivings })
895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921
  | null condecls
  = ppr new_or_data <+> pp_hdr context <+> pp_sig

  | otherwise
  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
       2 (pp_condecls condecls $$ pp_derivings)
  where
    pp_sig = case mb_sig of
               Nothing   -> empty
               Just kind -> dcolon <+> ppr kind
    pp_derivings = case derivings of
                     Nothing -> empty
                     Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]

instance OutputableBndr name => Outputable (HsDataDefn name) where
   ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d

instance Outputable NewOrData where
  ppr NewType  = ptext (sLit "newtype")
  ppr DataType = ptext (sLit "data")

pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
  = hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
pp_condecls cs                    -- In H98 syntax
  = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))