ghc/compiler/hsSyn/HsDecls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[HsDecls]{Abstract syntax: global declarations}
   5
   6 Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
   7 @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
   8
   9 \begin{code}
  10 module HsDecls (
  11         HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
  12         DefaultDecl(..), HsGroup(..), SpliceDecl(..),
  13         ForeignDecl(..), ForeignImport(..), ForeignExport(..),
  14         CImportSpec(..), FoType(..),
  15         ConDecl(..), CoreDecl(..),
  16         BangType(..), getBangType, getBangStrictness, unbangedType,
  17         DeprecDecl(..), DeprecTxt,
  18         tyClDeclName, tyClDeclNames, tyClDeclTyVars,
  19         isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl,
  20         isTypeOrClassDecl, countTyClDecls,
  21         isSourceInstDecl, instDeclDFun, ifaceRuleDeclName,
  22         conDetailsTys,
  23         collectRuleBndrSigTys, isSrcRule
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 -- friends:
  29 import {-# SOURCE #-}   HsExpr( HsExpr, pprExpr )
  30         -- Because Expr imports Decls via HsBracket
  31
  32 import HsBinds          ( HsBinds, MonoBinds, Sig(..) )
  33 import HsPat            ( HsConDetails(..), hsConArgs )
  34 import HsImpExp         ( pprHsVar )
  35 import HsTypes
  36 import PprCore          ( pprCoreRule )
  37 import HsCore           ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
  38                           eq_ufBinders, eq_ufExpr, pprUfExpr
  39                         )
  40 import CoreSyn          ( CoreRule(..), RuleName )
  41 import BasicTypes       ( NewOrData(..), StrictnessMark(..), Activation(..), FixitySig(..) )
  42 import ForeignCall      ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
  43                           CExportSpec(..))
  44
  45 -- others:
  46 import Name             ( NamedThing )
  47 import FunDeps          ( pprFundeps )
  48 import TyCon            ( DataConDetails(..), visibleDataCons )
  49 import Class            ( FunDep, DefMeth(..) )
  50 import CStrings         ( CLabelString )
  51 import Outputable
  52 import Util             ( eqListBy, count )
  53 import SrcLoc           ( SrcLoc )
  54 import FastString
  55
  56 import Maybe            ( isNothing, fromJust )
  57 \end{code}
  58
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection[HsDecl]{Declarations}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 \begin{code}
  67 data HsDecl id
  68   = TyClD       (TyClDecl id)
  69   | InstD       (InstDecl  id)
  70   | ValD        (MonoBinds id)
  71   | SigD        (Sig id)
  72   | DefD        (DefaultDecl id)
  73   | ForD        (ForeignDecl id)
  74   | DeprecD     (DeprecDecl id)
  75   | RuleD       (RuleDecl id)
  76   | CoreD       (CoreDecl id)
  77   | SpliceD     (SpliceDecl id)
  78
  79 -- NB: all top-level fixity decls are contained EITHER
  80 -- EITHER SigDs
  81 -- OR     in the ClassDecls in TyClDs
  82 --
  83 -- The former covers
  84 --      a) data constructors
  85 --      b) class methods (but they can be also done in the
  86 --              signatures of class decls)
  87 --      c) imported functions (that have an IfacSig)
  88 --      d) top level decls
  89 --
  90 -- The latter is for class methods only
  91
  92 -- A [HsDecl] is categorised into a HsGroup before being
  93 -- fed to the renamer.
  94 data HsGroup id
  95   = HsGroup {
  96         hs_valds  :: HsBinds id,
  97                 -- Before the renamer, this is a single big MonoBinds,
  98                 -- with all the bindings, and all the signatures.
  99                 -- The renamer does dependency analysis, using ThenBinds
 100                 -- to give the structure
 101
 102         hs_tyclds :: [TyClDecl id],
 103         hs_instds :: [InstDecl id],
 104
 105         hs_fixds  :: [FixitySig id],
 106                 -- Snaffled out of both top-level fixity signatures,
 107                 -- and those in class declarations
 108
 109         hs_defds  :: [DefaultDecl id],
 110         hs_fords  :: [ForeignDecl id],
 111         hs_depds  :: [DeprecDecl id],
 112         hs_ruleds :: [RuleDecl id],
 113         hs_coreds :: [CoreDecl id]
 114   }
 115 \end{code}
 116
 117 \begin{code}
 118 instance OutputableBndr name => Outputable (HsDecl name) where
 119     ppr (TyClD dcl)  = ppr dcl
 120     ppr (ValD binds) = ppr binds
 121     ppr (DefD def)   = ppr def
 122     ppr (InstD inst) = ppr inst
 123     ppr (ForD fd)    = ppr fd
 124     ppr (SigD sd)    = ppr sd
 125     ppr (RuleD rd)   = ppr rd
 126     ppr (DeprecD dd) = ppr dd
 127     ppr (CoreD dd)   = ppr dd
 128     ppr (SpliceD dd) = ppr dd
 129
 130 instance OutputableBndr name => Outputable (HsGroup name) where
 131     ppr (HsGroup { hs_valds  = val_decls,
 132                    hs_tyclds = tycl_decls,
 133                    hs_instds = inst_decls,
 134                    hs_fixds  = fix_decls,
 135                    hs_depds  = deprec_decls,
 136                    hs_fords  = foreign_decls,
 137                    hs_defds  = default_decls,
 138                    hs_ruleds = rule_decls,
 139                    hs_coreds = core_decls })
 140         = vcat [ppr_ds fix_decls, ppr_ds default_decls,
 141                 ppr_ds deprec_decls, ppr_ds rule_decls,
 142                 ppr val_decls,
 143                 ppr_ds tycl_decls, ppr_ds inst_decls,
 144                 ppr_ds foreign_decls, ppr_ds core_decls]
 145         where
 146           ppr_ds [] = empty
 147           ppr_ds ds = text "" $$ vcat (map ppr ds)
 148
 149 data SpliceDecl id = SpliceDecl (HsExpr id) SrcLoc      -- Top level splice
 150
 151 instance OutputableBndr name => Outputable (SpliceDecl name) where
 152    ppr (SpliceDecl e _) = ptext SLIT("$") <> parens (pprExpr e)
 153 \end{code}
 154
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162                 --------------------------------
 163                         THE NAMING STORY
 164                 --------------------------------
 165
 166 Here is the story about the implicit names that go with type, class, and instance
 167 decls.  It's a bit tricky, so pay attention!
 168
 169 "Implicit" (or "system") binders
 170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 171   Each data type decl defines
 172         a worker name for each constructor
 173         to-T and from-T convertors
 174   Each class decl defines
 175         a tycon for the class
 176         a data constructor for that tycon
 177         the worker for that constructor
 178         a selector for each superclass
 179
 180 All have occurrence names that are derived uniquely from their parent declaration.
 181
 182 None of these get separate definitions in an interface file; they are
 183 fully defined by the data or class decl.  But they may *occur* in
 184 interface files, of course.  Any such occurrence must haul in the
 185 relevant type or class decl.
 186
 187 Plan of attack:
 188  - Ensure they "point to" the parent data/class decl
 189    when loading that decl from an interface file
 190    (See RnHiFiles.getSysBinders)
 191
 192  - When typechecking the decl, we build the implicit TyCons and Ids.
 193    When doing so we look them up in the name cache (RnEnv.lookupSysName),
 194    to ensure correct module and provenance is set
 195
 196 These are the two places that we have to conjure up the magic derived
 197 names.  (The actual magic is in OccName.mkWorkerOcc, etc.)
 198
 199 Default methods
 200 ~~~~~~~~~~~~~~~
 201  - Occurrence name is derived uniquely from the method name
 202    E.g. $dmmax
 203
 204  - If there is a default method name at all, it's recorded in
 205    the ClassOpSig (in HsBinds), in the DefMeth field.
 206    (DefMeth is defined in Class.lhs)
 207
 208 Source-code class decls and interface-code class decls are treated subtly
 209 differently, which has given me a great deal of confusion over the years.
 210 Here's the deal.  (We distinguish the two cases because source-code decls
 211 have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.
 212
 213 In *source-code* class declarations:
 214
 215  - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
 216    This is done by RdrHsSyn.mkClassOpSigDM
 217
 218  - The renamer renames it to a Name
 219
 220  - During typechecking, we generate a binding for each $dm for
 221    which there's a programmer-supplied default method:
 222         class Foo a where
 223           op1 :: <type>
 224           op2 :: <type>
 225           op1 = ...
 226    We generate a binding for $dmop1 but not for $dmop2.
 227    The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
 228    The Name for $dmop2 is simply discarded.
 229
 230 In *interface-file* class declarations:
 231   - When parsing, we see if there's an explicit programmer-supplied default method
 232     because there's an '=' sign to indicate it:
 233         class Foo a where
 234           op1 = :: <type>       -- NB the '='
 235           op2   :: <type>
 236     We use this info to generate a DefMeth with a suitable RdrName for op1,
 237     and a NoDefMeth for op2
 238   - The interface file has a separate definition for $dmop1, with unfolding etc.
 239   - The renamer renames it to a Name.
 240   - The renamer treats $dmop1 as a free variable of the declaration, so that
 241     the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)
 242     This doesn't happen for source code class decls, because they *bind* the default method.
 243
 244 Dictionary functions
 245 ~~~~~~~~~~~~~~~~~~~~
 246 Each instance declaration gives rise to one dictionary function binding.
 247
 248 The type checker makes up new source-code instance declarations
 249 (e.g. from 'deriving' or generic default methods --- see
 250 TcInstDcls.tcInstDecls1).  So we can't generate the names for
 251 dictionary functions in advance (we don't know how many we need).
 252
 253 On the other hand for interface-file instance declarations, the decl
 254 specifies the name of the dictionary function, and it has a binding elsewhere
 255 in the interface file:
 256         instance {Eq Int} = dEqInt
 257         dEqInt :: {Eq Int} <pragma info>
 258
 259 So again we treat source code and interface file code slightly differently.
 260
 261 Source code:
 262   - Source code instance decls have a Nothing in the (Maybe name) field
 263     (see data InstDecl below)
 264
 265   - The typechecker makes up a Local name for the dict fun for any source-code
 266     instance decl, whether it comes from a source-code instance decl, or whether
 267     the instance decl is derived from some other construct (e.g. 'deriving').
 268
 269   - The occurrence name it chooses is derived from the instance decl (just for
 270     documentation really) --- e.g. dNumInt.  Two dict funs may share a common
 271     occurrence name, but will have different uniques.  E.g.
 272         instance Foo [Int]  where ...
 273         instance Foo [Bool] where ...
 274     These might both be dFooList
 275
 276   - The CoreTidy phase externalises the name, and ensures the occurrence name is
 277     unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.
 278
 279   - We can take this relaxed approach (changing the occurrence name later)
 280     because dict fun Ids are not captured in a TyCon or Class (unlike default
 281     methods, say).  Instead, they are kept separately in the InstEnv.  This
 282     makes it easy to adjust them after compiling a module.  (Once we've finished
 283     compiling that module, they don't change any more.)
 284
 285
 286 Interface file code:
 287   - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
 288     in the (Maybe name) field.
 289
 290   - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
 291     suck in the dfun binding
 292
 293
 294 \begin{code}
 295 -- TyClDecls are precisely the kind of declarations that can
 296 -- appear in interface files; or (internally) in GHC's interface
 297 -- for a module.  That's why (despite the misnomer) IfaceSig and ForeignType
 298 -- are both in TyClDecl
 299
 300 data TyClDecl name
 301   = IfaceSig {  tcdName :: name,                -- It may seem odd to classify an interface-file signature
 302                 tcdType :: HsType name,         -- as a 'TyClDecl', but it's very convenient.
 303                 tcdIdInfo :: [HsIdInfo name],
 304                 tcdLoc :: SrcLoc
 305     }
 306
 307   | ForeignType { tcdName    :: name,           -- See remarks about IfaceSig above
 308                   tcdExtName :: Maybe FastString,
 309                   tcdFoType  :: FoType,
 310                   tcdLoc     :: SrcLoc }
 311
 312   | TyData {    tcdND     :: NewOrData,
 313                 tcdCtxt   :: HsContext name,     -- Context
 314                 tcdName   :: name,               -- Type constructor
 315                 tcdTyVars :: [HsTyVarBndr name], -- Type variables
 316                 tcdCons   :: DataConDetails (ConDecl name),      -- Data constructors
 317                 tcdDerivs :: Maybe (HsContext name),    -- Derivings; Nothing => not specified
 318                                                         -- Just [] => derive exactly what is asked
 319                 tcdGeneric :: Maybe Bool,       -- Nothing <=> source decl
 320                                                 -- Just x  <=> interface-file decl;
 321                                                 --      x=True <=> generic converter functions available
 322                                                 -- We need this for imported data decls, since the
 323                                                 -- imported modules may have been compiled with
 324                                                 -- different flags to the current compilation unit
 325                 tcdLoc     :: SrcLoc
 326     }
 327
 328   | TySynonym { tcdName :: name,                        -- type constructor
 329                 tcdTyVars :: [HsTyVarBndr name],        -- type variables
 330                 tcdSynRhs :: HsType name,               -- synonym expansion
 331                 tcdLoc    :: SrcLoc
 332     }
 333
 334   | ClassDecl { tcdCtxt    :: HsContext name,           -- Context...
 335                 tcdName    :: name,                     -- Name of the class
 336                 tcdTyVars  :: [HsTyVarBndr name],       -- The class type variables
 337                 tcdFDs     :: [FunDep name],            -- Functional dependencies
 338                 tcdSigs    :: [Sig name],               -- Methods' signatures
 339                 tcdMeths   :: Maybe (MonoBinds name),   -- Default methods
 340                                                         --      Nothing for imported class decls
 341                                                         --      Just bs for source   class decls
 342                 tcdLoc      :: SrcLoc
 343     }
 344 \end{code}
 345
 346 Simple classifiers
 347
 348 \begin{code}
 349 isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool
 350
 351 isIfaceSigDecl (IfaceSig {}) = True
 352 isIfaceSigDecl other         = False
 353
 354 isSynDecl (TySynonym {}) = True
 355 isSynDecl other          = False
 356
 357 isDataDecl (TyData {}) = True
 358 isDataDecl other       = False
 359
 360 isClassDecl (ClassDecl {}) = True
 361 isClassDecl other          = False
 362
 363 isTypeOrClassDecl (ClassDecl   {}) = True
 364 isTypeOrClassDecl (TyData      {}) = True
 365 isTypeOrClassDecl (TySynonym   {}) = True
 366 isTypeOrClassDecl (ForeignType {}) = True
 367 isTypeOrClassDecl other            = False
 368 \end{code}
 369
 370 Dealing with names
 371
 372 \begin{code}
 373 --------------------------------
 374 tyClDeclName :: TyClDecl name -> name
 375 tyClDeclName tycl_decl = tcdName tycl_decl
 376
 377 --------------------------------
 378 tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)]
 379 -- Returns all the *binding* names of the decl, along with their SrcLocs
 380 -- The first one is guaranteed to be the name of the decl
 381 -- For record fields, the first one counts as the SrcLoc
 382 -- We use the equality to filter out duplicate field names
 383
 384 tyClDeclNames (TySynonym   {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 385 tyClDeclNames (IfaceSig    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 386 tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 387
 388 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
 389   = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
 390
 391 tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
 392   = (tc_name,loc) : conDeclsNames cons
 393
 394
 395 tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
 396 tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
 397 tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
 398 tyClDeclTyVars (ForeignType {})              = []
 399 tyClDeclTyVars (IfaceSig {})                 = []
 400 \end{code}
 401
 402 \begin{code}
 403 instance (NamedThing name, Ord name) => Eq (TyClDecl name) where
 404         -- Used only when building interface files
 405   (==) d1@(IfaceSig {}) d2@(IfaceSig {})
 406       = tcdName d1 == tcdName d2 &&
 407         tcdType d1 == tcdType d2 &&
 408         tcdIdInfo d1 == tcdIdInfo d2
 409
 410   (==) d1@(ForeignType {}) d2@(ForeignType {})
 411       = tcdName d1 == tcdName d2 &&
 412         tcdFoType d1 == tcdFoType d2
 413
 414   (==) d1@(TyData {}) d2@(TyData {})
 415       = tcdName d1 == tcdName d2 &&
 416         tcdND d1   == tcdND   d2 &&
 417         eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 418           eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
 419           eq_hsCD      env (tcdCons d1) (tcdCons d2)
 420         )
 421
 422   (==) d1@(TySynonym {}) d2@(TySynonym {})
 423       = tcdName d1 == tcdName d2 &&
 424         eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 425           eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2)
 426         )
 427
 428   (==) d1@(ClassDecl {}) d2@(ClassDecl {})
 429     = tcdName d1 == tcdName d2 &&
 430       eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 431           eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
 432           eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) &&
 433           eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2)
 434        )
 435
 436   (==) _ _ = False      -- default case
 437
 438 eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
 439 eq_hsCD env Unknown       Unknown       = True
 440 eq_hsCD env (HasCons n1)  (HasCons n2)  = n1 == n2
 441 eq_hsCD env d1            d2            = False
 442
 443 eq_hsFD env (ns1,ms1) (ns2,ms2)
 444   = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
 445
 446 eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
 447   = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
 448   where
 449         -- Ignore the name of the default method for (DefMeth id)
 450         -- This is used for comparing declarations before putting
 451         -- them into interface files, and the name of the default
 452         -- method isn't relevant
 453     NoDefMeth  `eq_dm` NoDefMeth  = True
 454     GenDefMeth `eq_dm` GenDefMeth = True
 455     DefMeth _  `eq_dm` DefMeth _  = True
 456     dm1        `eq_dm` dm2        = False
 457 \end{code}
 458
 459 \begin{code}
 460 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
 461         -- class, data, newtype, synonym decls
 462 countTyClDecls decls
 463  = (count isClassDecl     decls,
 464     count isSynDecl       decls,
 465     count isIfaceSigDecl  decls,
 466     count isDataTy        decls,
 467     count isNewTy         decls)
 468  where
 469    isDataTy TyData{tcdND=DataType} = True
 470    isDataTy _                      = False
 471
 472    isNewTy TyData{tcdND=NewType} = True
 473    isNewTy _                     = False
 474 \end{code}
 475
 476 \begin{code}
 477 instance OutputableBndr name
 478               => Outputable (TyClDecl name) where
 479
 480     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
 481         = getPprStyle $ \ sty ->
 482            hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ]
 483
 484     ppr (ForeignType {tcdName = tycon})
 485         = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 486
 487     ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
 488       = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
 489              4 (ppr mono_ty)
 490
 491     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 492                  tcdTyVars = tyvars, tcdCons = condecls,
 493                  tcdDerivs = derivings})
 494       = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
 495                   (pp_condecls condecls)
 496                   derivings
 497       where
 498         keyword = case new_or_data of
 499                         NewType  -> SLIT("newtype")
 500                         DataType -> SLIT("data")
 501
 502     ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds,
 503                     tcdSigs = sigs, tcdMeths = methods})
 504       | null sigs       -- No "where" part
 505       = top_matter
 506
 507       | otherwise       -- Laid out
 508       = sep [hsep [top_matter, ptext SLIT("where {")],
 509              nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
 510       where
 511         top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
 512         ppr_sig sig = ppr sig <> semi
 513
 514         pp_methods = if isNothing methods
 515                         then empty
 516                         else ppr (fromJust methods)
 517
 518 pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 519 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 520
 521 pp_condecls Unknown       = ptext SLIT("{- abstract -}")
 522 pp_condecls (HasCons n)   = ptext SLIT("{- abstract with") <+> int n <+> ptext SLIT("constructors -}")
 523 pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
 524
 525 pp_tydecl pp_head pp_decl_rhs derivings
 526   = hang pp_head 4 (sep [
 527         pp_decl_rhs,
 528         case derivings of
 529           Nothing          -> empty
 530           Just ds          -> hsep [ptext SLIT("deriving"), ppr_hs_context ds]
 531     ])
 532 \end{code}
 533
 534
 535 %************************************************************************
 536 %*                                                                      *
 537 \subsection[ConDecl]{A data-constructor declaration}
 538 %*                                                                      *
 539 %************************************************************************
 540
 541 \begin{code}
 542 data ConDecl name
 543   = ConDecl     name                    -- Constructor name; this is used for the
 544                                         -- DataCon itself, and for the user-callable wrapper Id
 545
 546                 [HsTyVarBndr name]      -- Existentially quantified type variables
 547                 (HsContext name)        -- ...and context
 548                                         -- If both are empty then there are no existentials
 549
 550                 (HsConDetails name (BangType name))
 551                 SrcLoc
 552 \end{code}
 553
 554 \begin{code}
 555 conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)]
 556   -- See tyClDeclNames for what this does
 557   -- The function is boringly complicated because of the records
 558   -- And since we only have equality, we have to be a little careful
 559 conDeclsNames cons
 560   = snd (foldl do_one ([], []) (visibleDataCons cons))
 561   where
 562     do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc)
 563         = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc)
 564         where
 565           new_flds = [ f | (f,_) <- flds, not (f `elem` flds_seen) ]
 566
 567     do_one (flds_seen, acc) (ConDecl name _ _ _ loc)
 568         = (flds_seen, (name,loc):acc)
 569 \end{code}
 570
 571 \begin{code}
 572 conDetailsTys details = map getBangType (hsConArgs details)
 573
 574 eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _)
 575                (ConDecl n2 tvs2 cxt2 cds2 _)
 576   = n1 == n2 &&
 577     (eq_hsTyVars env tvs1 tvs2  $ \ env ->
 578      eq_hsContext env cxt1 cxt2 &&
 579      eq_ConDetails env cds1 cds2)
 580
 581 eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2)
 582   = eqListBy (eq_btype env) bts1 bts2
 583 eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2)
 584   = eq_btype env bta1 bta2 && eq_btype env btb1 btb2
 585 eq_ConDetails env (RecCon fs1) (RecCon fs2)
 586   = eqListBy (eq_fld env) fs1 fs2
 587 eq_ConDetails env _ _ = False
 588
 589 eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
 590 \end{code}
 591
 592 \begin{code}
 593 data BangType name = BangType StrictnessMark (HsType name)
 594
 595 getBangType       (BangType _ ty) = ty
 596 getBangStrictness (BangType s _)  = s
 597
 598 unbangedType ty = BangType NotMarkedStrict ty
 599
 600 eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2
 601 \end{code}
 602
 603 \begin{code}
 604 instance (OutputableBndr name) => Outputable (ConDecl name) where
 605     ppr (ConDecl con tvs cxt con_details loc)
 606       = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
 607
 608 ppr_con_details con (InfixCon ty1 ty2)
 609   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 610
 611 -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
 612 -- if the constructor is an infix one.  This is because in an interface file
 613 -- we don't distinguish between the two.  Hence when printing these for the
 614 -- user, we need to parenthesise infix constructor names.
 615 ppr_con_details con (PrefixCon tys)
 616   = hsep (pprHsVar con : map ppr_bang tys)
 617
 618 ppr_con_details con (RecCon fields)
 619   = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
 620   where
 621     ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty
 622
 623 instance OutputableBndr name => Outputable (BangType name) where
 624     ppr = ppr_bang
 625
 626 ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty
 627 \end{code}
 628
 629
 630 %************************************************************************
 631 %*                                                                      *
 632 \subsection[InstDecl]{An instance declaration
 633 %*                                                                      *
 634 %************************************************************************
 635
 636 \begin{code}
 637 data InstDecl name
 638   = InstDecl    (HsType name)   -- Context => Class Instance-type
 639                                 -- Using a polytype means that the renamer conveniently
 640                                 -- figures out the quantified type variables for us.
 641
 642                 (MonoBinds name)
 643
 644                 [Sig name]              -- User-supplied pragmatic info
 645
 646                 (Maybe name)            -- Name for the dictionary function
 647                                         -- Nothing for source-file instance decls
 648
 649                 SrcLoc
 650
 651 isSourceInstDecl :: InstDecl name -> Bool
 652 isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun
 653
 654 instDeclDFun :: InstDecl name -> Maybe name
 655 instDeclDFun (InstDecl _ _ _ df _) = df -- A Maybe, but that's ok
 656 \end{code}
 657
 658 \begin{code}
 659 instance (OutputableBndr name) => Outputable (InstDecl name) where
 660
 661     ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
 662       = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
 663               nest 4 (ppr uprags),
 664               nest 4 (ppr binds) ]
 665       where
 666         pp_dfun = case maybe_dfun_name of
 667                     Just df -> ppr df
 668                     Nothing -> empty
 669 \end{code}
 670
 671 \begin{code}
 672 instance Ord name => Eq (InstDecl name) where
 673         -- Used for interface comparison only, so don't compare bindings
 674   (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _)
 675        = inst_ty1 == inst_ty2 && dfun1 == dfun2
 676 \end{code}
 677
 678
 679 %************************************************************************
 680 %*                                                                      *
 681 \subsection[DefaultDecl]{A @default@ declaration}
 682 %*                                                                      *
 683 %************************************************************************
 684
 685 There can only be one default declaration per module, but it is hard
 686 for the parser to check that; we pass them all through in the abstract
 687 syntax, and that restriction must be checked in the front end.
 688
 689 \begin{code}
 690 data DefaultDecl name
 691   = DefaultDecl [HsType name]
 692                 SrcLoc
 693
 694 instance (OutputableBndr name)
 695               => Outputable (DefaultDecl name) where
 696
 697     ppr (DefaultDecl tys src_loc)
 698       = ptext SLIT("default") <+> parens (interpp'SP tys)
 699 \end{code}
 700
 701 %************************************************************************
 702 %*                                                                      *
 703 \subsection{Foreign function interface declaration}
 704 %*                                                                      *
 705 %************************************************************************
 706
 707 \begin{code}
 708
 709 -- foreign declarations are distinguished as to whether they define or use a
 710 -- Haskell name
 711 --
 712 -- * the Boolean value indicates whether the pre-standard deprecated syntax
 713 --   has been used
 714 --
 715 data ForeignDecl name
 716   = ForeignImport name (HsType name) ForeignImport Bool SrcLoc  -- defines name
 717   | ForeignExport name (HsType name) ForeignExport Bool SrcLoc  -- uses name
 718
 719 -- yield the Haskell name defined or used in a foreign declaration
 720 --
 721 foreignDeclName                           :: ForeignDecl name -> name
 722 foreignDeclName (ForeignImport n _ _ _ _)  = n
 723 foreignDeclName (ForeignExport n _ _ _ _)  = n
 724
 725 -- specification of an imported external entity in dependence on the calling
 726 -- convention
 727 --
 728 data ForeignImport = -- import of a C entity
 729                      --
 730                      -- * the two strings specifying a header file or library
 731                      --   may be empty, which indicates the absence of a
 732                      --   header or object specification (both are not used
 733                      --   in the case of `CWrapper' and when `CFunction'
 734                      --   has a dynamic target)
 735                      --
 736                      -- * the calling convention is irrelevant for code
 737                      --   generation in the case of `CLabel', but is needed
 738                      --   for pretty printing
 739                      --
 740                      -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
 741                      --
 742                      CImport  CCallConv       -- ccall or stdcall
 743                               Safety          -- safe or unsafe
 744                               FastString      -- name of C header
 745                               FastString      -- name of library object
 746                               CImportSpec     -- details of the C entity
 747
 748                      -- import of a .NET function
 749                      --
 750                    | DNImport DNCallSpec
 751
 752 -- details of an external C entity
 753 --
 754 data CImportSpec = CLabel    CLabelString     -- import address of a C label
 755                  | CFunction CCallTarget      -- static or dynamic function
 756                  | CWrapper                   -- wrapper to expose closures
 757                                               -- (former f.e.d.)
 758
 759 -- specification of an externally exported entity in dependence on the calling
 760 -- convention
 761 --
 762 data ForeignExport = CExport  CExportSpec    -- contains the calling convention
 763                    | DNExport                -- presently unused
 764
 765 -- abstract type imported from .NET
 766 --
 767 data FoType = DNType            -- In due course we'll add subtype stuff
 768             deriving (Eq)       -- Used for equality instance for TyClDecl
 769
 770
 771 -- pretty printing of foreign declarations
 772 --
 773
 774 instance OutputableBndr name => Outputable (ForeignDecl name) where
 775   ppr (ForeignImport n ty fimport _ _) =
 776     ptext SLIT("foreign import") <+> ppr fimport <+>
 777     ppr n <+> dcolon <+> ppr ty
 778   ppr (ForeignExport n ty fexport _ _) =
 779     ptext SLIT("foreign export") <+> ppr fexport <+>
 780     ppr n <+> dcolon <+> ppr ty
 781
 782 instance Outputable ForeignImport where
 783   ppr (DNImport                         spec) =
 784     ptext SLIT("dotnet") <+> ppr spec
 785   ppr (CImport  cconv safety header lib spec) =
 786     ppr cconv <+> ppr safety <+>
 787     char '"' <> pprCEntity header lib spec <> char '"'
 788     where
 789       pprCEntity header lib (CLabel lbl) =
 790         ptext SLIT("static") <+> ftext header <+> char '&' <>
 791         pprLib lib <> ppr lbl
 792       pprCEntity header lib (CFunction (StaticTarget lbl)) =
 793         ptext SLIT("static") <+> ftext header <+> char '&' <>
 794         pprLib lib <> ppr lbl
 795       pprCEntity header lib (CFunction (DynamicTarget)) =
 796         ptext SLIT("dynamic")
 797       pprCEntity header lib (CFunction (CasmTarget _)) =
 798         panic "HsDecls.pprCEntity: malformed C function target"
 799       pprCEntity _      _   (CWrapper) = ptext SLIT("wrapper")
 800       --
 801       pprLib lib | nullFastString lib = empty
 802                  | otherwise          = char '[' <> ppr lib <> char ']'
 803
 804 instance Outputable ForeignExport where
 805   ppr (CExport  (CExportStatic lbl cconv)) =
 806     ppr cconv <+> char '"' <> ppr lbl <> char '"'
 807   ppr (DNExport                          ) =
 808     ptext SLIT("dotnet") <+> ptext SLIT("\"<unused>\"")
 809
 810 instance Outputable FoType where
 811   ppr DNType = ptext SLIT("type dotnet")
 812 \end{code}
 813
 814
 815 %************************************************************************
 816 %*                                                                      *
 817 \subsection{Transformation rules}
 818 %*                                                                      *
 819 %************************************************************************
 820
 821 \begin{code}
 822 data RuleDecl name
 823   = HsRule                      -- Source rule
 824         RuleName                -- Rule name
 825         Activation
 826         [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
 827         (HsExpr name)   -- LHS
 828         (HsExpr name)   -- RHS
 829         SrcLoc
 830
 831   | IfaceRule                   -- One that's come in from an interface file; pre-typecheck
 832         RuleName
 833         Activation
 834         [UfBinder name]         -- Tyvars and term vars
 835         name                    -- Head of lhs
 836         [UfExpr name]           -- Args of LHS
 837         (UfExpr name)           -- Pre typecheck
 838         SrcLoc
 839
 840   | IfaceRuleOut                -- Post typecheck
 841         name                    -- Head of LHS
 842         CoreRule
 843
 844 isSrcRule :: RuleDecl name -> Bool
 845 isSrcRule (HsRule _ _ _ _ _ _) = True
 846 isSrcRule other                = False
 847
 848 ifaceRuleDeclName :: RuleDecl name -> name
 849 ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
 850 ifaceRuleDeclName (IfaceRuleOut n r)        = n
 851 ifaceRuleDeclName (HsRule fs _ _ _ _ _)     = pprPanic "ifaceRuleDeclName" (ppr fs)
 852
 853 data RuleBndr name
 854   = RuleBndr name
 855   | RuleBndrSig name (HsType name)
 856
 857 collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
 858 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 859
 860 instance (NamedThing name, Ord name) => Eq (RuleDecl name) where
 861   -- Works for IfaceRules only; used when comparing interface file versions
 862   (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
 863      = n1==n2 && f1 == f2 && a1==a2 &&
 864        eq_ufBinders emptyEqHsEnv bs1 bs2 (\env ->
 865        eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
 866
 867 instance OutputableBndr name => Outputable (RuleDecl name) where
 868   ppr (HsRule name act ns lhs rhs loc)
 869         = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
 870                pp_forall, pprExpr lhs, equals <+> pprExpr rhs,
 871                text "#-}" ]
 872         where
 873           pp_forall | null ns   = empty
 874                     | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
 875
 876   ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc)
 877     = hsep [ doubleQuotes (ftext name), ppr act,
 878            ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
 879            ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
 880            ptext SLIT("=") <+> ppr rhs
 881       ] <+> semi
 882
 883   ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule
 884
 885 instance OutputableBndr name => Outputable (RuleBndr name) where
 886    ppr (RuleBndr name) = ppr name
 887    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 888 \end{code}
 889
 890
 891 %************************************************************************
 892 %*                                                                      *
 893 \subsection[DeprecDecl]{Deprecations}
 894 %*                                                                      *
 895 %************************************************************************
 896
 897 We use exported entities for things to deprecate.
 898
 899 \begin{code}
 900 data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
 901
 902 type DeprecTxt = FastString     -- reason/explanation for deprecation
 903
 904 instance OutputableBndr name => Outputable (DeprecDecl name) where
 905     ppr (Deprecation thing txt _)
 906       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 907 \end{code}
 908
 909
 910 %************************************************************************
 911 %*                                                                      *
 912                 External-core declarations
 913 %*                                                                      *
 914 %************************************************************************
 915
 916 \begin{code}
 917 data CoreDecl name      -- a Core value binding (from 'external Core' input)
 918   = CoreDecl    name
 919                 (HsType name)
 920                 (UfExpr name)
 921                 SrcLoc
 922
 923 instance OutputableBndr name => Outputable (CoreDecl name) where
 924     ppr (CoreDecl var ty rhs loc)
 925         = getPprStyle $ \ sty ->
 926           hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ]
 927 \end{code}