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  - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName
 215    This is done by RdrHsSyn.mkClassOpSigDM
 216
 217  - The renamer renames it to a Name
 218
 219  - During typechecking, we generate a binding for each $dm for
 220    which there's a programmer-supplied default method:
 221         class Foo a where
 222           op1 :: <type>
 223           op2 :: <type>
 224           op1 = ...
 225    We generate a binding for $dmop1 but not for $dmop2.
 226    The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
 227    The Name for $dmop2 is simply discarded.
 228
 229 In *interface-file* class declarations:
 230   - When parsing, we see if there's an explicit programmer-supplied default method
 231     because there's an '=' sign to indicate it:
 232         class Foo a where
 233           op1 = :: <type>       -- NB the '='
 234           op2   :: <type>
 235     We use this info to generate a DefMeth with a suitable RdrName for op1,
 236     and a NoDefMeth for op2
 237   - The interface file has a separate definition for $dmop1, with unfolding etc.
 238   - The renamer renames it to a Name.
 239   - The renamer treats $dmop1 as a free variable of the declaration, so that
 240     the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)
 241     This doesn't happen for source code class decls, because they *bind* the default method.
 242
 243 Dictionary functions
 244 ~~~~~~~~~~~~~~~~~~~~
 245 Each instance declaration gives rise to one dictionary function binding.
 246
 247 The type checker makes up new source-code instance declarations
 248 (e.g. from 'deriving' or generic default methods --- see
 249 TcInstDcls.tcInstDecls1).  So we can't generate the names for
 250 dictionary functions in advance (we don't know how many we need).
 251
 252 On the other hand for interface-file instance declarations, the decl
 253 specifies the name of the dictionary function, and it has a binding elsewhere
 254 in the interface file:
 255         instance {Eq Int} = dEqInt
 256         dEqInt :: {Eq Int} <pragma info>
 257
 258 So again we treat source code and interface file code slightly differently.
 259
 260 Source code:
 261   - Source code instance decls have a Nothing in the (Maybe name) field
 262     (see data InstDecl below)
 263
 264   - The typechecker makes up a Local name for the dict fun for any source-code
 265     instance decl, whether it comes from a source-code instance decl, or whether
 266     the instance decl is derived from some other construct (e.g. 'deriving').
 267
 268   - The occurrence name it chooses is derived from the instance decl (just for
 269     documentation really) --- e.g. dNumInt.  Two dict funs may share a common
 270     occurrence name, but will have different uniques.  E.g.
 271         instance Foo [Int]  where ...
 272         instance Foo [Bool] where ...
 273     These might both be dFooList
 274
 275   - The CoreTidy phase externalises the name, and ensures the occurrence name is
 276     unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.
 277
 278   - We can take this relaxed approach (changing the occurrence name later)
 279     because dict fun Ids are not captured in a TyCon or Class (unlike default
 280     methods, say).  Instead, they are kept separately in the InstEnv.  This
 281     makes it easy to adjust them after compiling a module.  (Once we've finished
 282     compiling that module, they don't change any more.)
 283
 284
 285 Interface file code:
 286   - The instance decl gives the dict fun name, so the InstDecl has a (Just name)
 287     in the (Maybe name) field.
 288
 289   - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
 290     suck in the dfun binding
 291
 292
 293 \begin{code}
 294 -- TyClDecls are precisely the kind of declarations that can
 295 -- appear in interface files; or (internally) in GHC's interface
 296 -- for a module.  That's why (despite the misnomer) IfaceSig and ForeignType
 297 -- are both in TyClDecl
 298
 299 data TyClDecl name
 300   = IfaceSig {  tcdName :: name,                -- It may seem odd to classify an interface-file signature
 301                 tcdType :: HsType name,         -- as a 'TyClDecl', but it's very convenient.
 302                 tcdIdInfo :: [HsIdInfo name],
 303                 tcdLoc :: SrcLoc
 304     }
 305
 306   | ForeignType { tcdName    :: name,           -- See remarks about IfaceSig above
 307                   tcdExtName :: Maybe FastString,
 308                   tcdFoType  :: FoType,
 309                   tcdLoc     :: SrcLoc }
 310
 311   | TyData {    tcdND     :: NewOrData,
 312                 tcdCtxt   :: HsContext name,     -- Context
 313                 tcdName   :: name,               -- Type constructor
 314                 tcdTyVars :: [HsTyVarBndr name], -- Type variables
 315                 tcdCons   :: DataConDetails (ConDecl name),      -- Data constructors
 316                 tcdDerivs :: Maybe (HsContext name),    -- Derivings; Nothing => not specified
 317                                                         -- Just [] => derive exactly what is asked
 318                 tcdGeneric :: Maybe Bool,       -- Nothing <=> source decl
 319                                                 -- Just x  <=> interface-file decl;
 320                                                 --      x=True <=> generic converter functions available
 321                                                 -- We need this for imported data decls, since the
 322                                                 -- imported modules may have been compiled with
 323                                                 -- different flags to the current compilation unit
 324                 tcdLoc     :: SrcLoc
 325     }
 326
 327   | TySynonym { tcdName :: name,                        -- type constructor
 328                 tcdTyVars :: [HsTyVarBndr name],        -- type variables
 329                 tcdSynRhs :: HsType name,               -- synonym expansion
 330                 tcdLoc    :: SrcLoc
 331     }
 332
 333   | ClassDecl { tcdCtxt    :: HsContext name,           -- Context...
 334                 tcdName    :: name,                     -- Name of the class
 335                 tcdTyVars  :: [HsTyVarBndr name],       -- The class type variables
 336                 tcdFDs     :: [FunDep name],            -- Functional dependencies
 337                 tcdSigs    :: [Sig name],               -- Methods' signatures
 338                 tcdMeths   :: Maybe (MonoBinds name),   -- Default methods
 339                                                         --      Nothing for imported class decls
 340                                                         --      Just bs for source   class decls
 341                 tcdLoc      :: SrcLoc
 342     }
 343 \end{code}
 344
 345 Simple classifiers
 346
 347 \begin{code}
 348 isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool
 349
 350 isIfaceSigDecl (IfaceSig {}) = True
 351 isIfaceSigDecl other         = False
 352
 353 isSynDecl (TySynonym {}) = True
 354 isSynDecl other          = False
 355
 356 isDataDecl (TyData {}) = True
 357 isDataDecl other       = False
 358
 359 isClassDecl (ClassDecl {}) = True
 360 isClassDecl other          = False
 361
 362 isTypeOrClassDecl (ClassDecl   {}) = True
 363 isTypeOrClassDecl (TyData      {}) = True
 364 isTypeOrClassDecl (TySynonym   {}) = True
 365 isTypeOrClassDecl (ForeignType {}) = True
 366 isTypeOrClassDecl other            = False
 367 \end{code}
 368
 369 Dealing with names
 370
 371 \begin{code}
 372 --------------------------------
 373 tyClDeclName :: TyClDecl name -> name
 374 tyClDeclName tycl_decl = tcdName tycl_decl
 375
 376 --------------------------------
 377 tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)]
 378 -- Returns all the *binding* names of the decl, along with their SrcLocs
 379 -- The first one is guaranteed to be the name of the decl
 380 -- For record fields, the first one counts as the SrcLoc
 381 -- We use the equality to filter out duplicate field names
 382
 383 tyClDeclNames (TySynonym   {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 384 tyClDeclNames (IfaceSig    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 385 tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 386
 387 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
 388   = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
 389
 390 tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
 391   = (tc_name,loc) : conDeclsNames cons
 392
 393
 394 tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
 395 tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
 396 tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
 397 tyClDeclTyVars (ForeignType {})              = []
 398 tyClDeclTyVars (IfaceSig {})                 = []
 399 \end{code}
 400
 401 \begin{code}
 402 instance (NamedThing name, Ord name) => Eq (TyClDecl name) where
 403         -- Used only when building interface files
 404   (==) d1@(IfaceSig {}) d2@(IfaceSig {})
 405       = tcdName d1 == tcdName d2 &&
 406         tcdType d1 == tcdType d2 &&
 407         tcdIdInfo d1 == tcdIdInfo d2
 408
 409   (==) d1@(ForeignType {}) d2@(ForeignType {})
 410       = tcdName d1 == tcdName d2 &&
 411         tcdFoType d1 == tcdFoType d2
 412
 413   (==) d1@(TyData {}) d2@(TyData {})
 414       = tcdName d1 == tcdName d2 &&
 415         tcdND d1   == tcdND   d2 &&
 416         eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 417           eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
 418           eq_hsCD      env (tcdCons d1) (tcdCons d2)
 419         )
 420
 421   (==) d1@(TySynonym {}) d2@(TySynonym {})
 422       = tcdName d1 == tcdName d2 &&
 423         eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 424           eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2)
 425         )
 426
 427   (==) d1@(ClassDecl {}) d2@(ClassDecl {})
 428     = tcdName d1 == tcdName d2 &&
 429       eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
 430           eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
 431           eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) &&
 432           eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2)
 433        )
 434
 435   (==) _ _ = False      -- default case
 436
 437 eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
 438 eq_hsCD env Unknown       Unknown       = True
 439 eq_hsCD env (HasCons n1)  (HasCons n2)  = n1 == n2
 440 eq_hsCD env d1            d2            = False
 441
 442 eq_hsFD env (ns1,ms1) (ns2,ms2)
 443   = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
 444
 445 eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
 446   = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
 447   where
 448         -- Ignore the name of the default method for (DefMeth id)
 449         -- This is used for comparing declarations before putting
 450         -- them into interface files, and the name of the default
 451         -- method isn't relevant
 452     NoDefMeth  `eq_dm` NoDefMeth  = True
 453     GenDefMeth `eq_dm` GenDefMeth = True
 454     DefMeth _  `eq_dm` DefMeth _  = True
 455     dm1        `eq_dm` dm2        = False
 456 \end{code}
 457
 458 \begin{code}
 459 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
 460         -- class, data, newtype, synonym decls
 461 countTyClDecls decls
 462  = (count isClassDecl     decls,
 463     count isSynDecl       decls,
 464     count isIfaceSigDecl  decls,
 465     count isDataTy        decls,
 466     count isNewTy         decls)
 467  where
 468    isDataTy TyData{tcdND=DataType} = True
 469    isDataTy _                      = False
 470
 471    isNewTy TyData{tcdND=NewType} = True
 472    isNewTy _                     = False
 473 \end{code}
 474
 475 \begin{code}
 476 instance OutputableBndr name
 477               => Outputable (TyClDecl name) where
 478
 479     ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
 480         = getPprStyle $ \ sty ->
 481            hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ]
 482
 483     ppr (ForeignType {tcdName = tycon})
 484         = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 485
 486     ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
 487       = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
 488              4 (ppr mono_ty)
 489
 490     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 491                  tcdTyVars = tyvars, tcdCons = condecls,
 492                  tcdDerivs = derivings})
 493       = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
 494                   (pp_condecls condecls)
 495                   derivings
 496       where
 497         keyword = case new_or_data of
 498                         NewType  -> SLIT("newtype")
 499                         DataType -> SLIT("data")
 500
 501     ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds,
 502                     tcdSigs = sigs, tcdMeths = methods})
 503       | null sigs       -- No "where" part
 504       = top_matter
 505
 506       | otherwise       -- Laid out
 507       = sep [hsep [top_matter, ptext SLIT("where {")],
 508              nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
 509       where
 510         top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
 511         ppr_sig sig = ppr sig <> semi
 512
 513         pp_methods = if isNothing methods
 514                         then empty
 515                         else ppr (fromJust methods)
 516
 517 pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 518 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 519
 520 pp_condecls Unknown       = ptext SLIT("{- abstract -}")
 521 pp_condecls (HasCons n)   = ptext SLIT("{- abstract with") <+> int n <+> ptext SLIT("constructors -}")
 522 pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
 523
 524 pp_tydecl pp_head pp_decl_rhs derivings
 525   = hang pp_head 4 (sep [
 526         pp_decl_rhs,
 527         case derivings of
 528           Nothing          -> empty
 529           Just ds          -> hsep [ptext SLIT("deriving"), ppr_hs_context ds]
 530     ])
 531 \end{code}
 532
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection[ConDecl]{A data-constructor declaration}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 \begin{code}
 541 data ConDecl name
 542   = ConDecl     name                    -- Constructor name; this is used for the
 543                                         -- DataCon itself, and for the user-callable wrapper Id
 544
 545                 [HsTyVarBndr name]      -- Existentially quantified type variables
 546                 (HsContext name)        -- ...and context
 547                                         -- If both are empty then there are no existentials
 548
 549                 (HsConDetails name (BangType name))
 550                 SrcLoc
 551 \end{code}
 552
 553 \begin{code}
 554 conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)]
 555   -- See tyClDeclNames for what this does
 556   -- The function is boringly complicated because of the records
 557   -- And since we only have equality, we have to be a little careful
 558 conDeclsNames cons
 559   = snd (foldl do_one ([], []) (visibleDataCons cons))
 560   where
 561     do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc)
 562         = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc)
 563         where
 564           new_flds = [ f | (f,_) <- flds, not (f `elem` flds_seen) ]
 565
 566     do_one (flds_seen, acc) (ConDecl name _ _ _ loc)
 567         = (flds_seen, (name,loc):acc)
 568 \end{code}
 569
 570 \begin{code}
 571 conDetailsTys details = map getBangType (hsConArgs details)
 572
 573 eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _)
 574                (ConDecl n2 tvs2 cxt2 cds2 _)
 575   = n1 == n2 &&
 576     (eq_hsTyVars env tvs1 tvs2  $ \ env ->
 577      eq_hsContext env cxt1 cxt2 &&
 578      eq_ConDetails env cds1 cds2)
 579
 580 eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2)
 581   = eqListBy (eq_btype env) bts1 bts2
 582 eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2)
 583   = eq_btype env bta1 bta2 && eq_btype env btb1 btb2
 584 eq_ConDetails env (RecCon fs1) (RecCon fs2)
 585   = eqListBy (eq_fld env) fs1 fs2
 586 eq_ConDetails env _ _ = False
 587
 588 eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
 589 \end{code}
 590
 591 \begin{code}
 592 data BangType name = BangType StrictnessMark (HsType name)
 593
 594 getBangType       (BangType _ ty) = ty
 595 getBangStrictness (BangType s _)  = s
 596
 597 unbangedType ty = BangType NotMarkedStrict ty
 598
 599 eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2
 600 \end{code}
 601
 602 \begin{code}
 603 instance (OutputableBndr name) => Outputable (ConDecl name) where
 604     ppr (ConDecl con tvs cxt con_details loc)
 605       = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
 606
 607 ppr_con_details con (InfixCon ty1 ty2)
 608   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 609
 610 -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
 611 -- if the constructor is an infix one.  This is because in an interface file
 612 -- we don't distinguish between the two.  Hence when printing these for the
 613 -- user, we need to parenthesise infix constructor names.
 614 ppr_con_details con (PrefixCon tys)
 615   = hsep (pprHsVar con : map ppr_bang tys)
 616
 617 ppr_con_details con (RecCon fields)
 618   = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
 619   where
 620     ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty
 621
 622 instance OutputableBndr name => Outputable (BangType name) where
 623     ppr = ppr_bang
 624
 625 ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty
 626 \end{code}
 627
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 \subsection[InstDecl]{An instance declaration
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 \begin{code}
 636 data InstDecl name
 637   = InstDecl    (HsType name)   -- Context => Class Instance-type
 638                                 -- Using a polytype means that the renamer conveniently
 639                                 -- figures out the quantified type variables for us.
 640
 641                 (MonoBinds name)
 642
 643                 [Sig name]              -- User-supplied pragmatic info
 644
 645                 (Maybe name)            -- Name for the dictionary function
 646                                         -- Nothing for source-file instance decls
 647
 648                 SrcLoc
 649
 650 isSourceInstDecl :: InstDecl name -> Bool
 651 isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun
 652
 653 instDeclDFun :: InstDecl name -> Maybe name
 654 instDeclDFun (InstDecl _ _ _ df _) = df -- A Maybe, but that's ok
 655 \end{code}
 656
 657 \begin{code}
 658 instance (OutputableBndr name) => Outputable (InstDecl name) where
 659
 660     ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
 661       = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
 662               nest 4 (ppr uprags),
 663               nest 4 (ppr binds) ]
 664       where
 665         pp_dfun = case maybe_dfun_name of
 666                     Just df -> ppr df
 667                     Nothing -> empty
 668 \end{code}
 669
 670 \begin{code}
 671 instance Ord name => Eq (InstDecl name) where
 672         -- Used for interface comparison only, so don't compare bindings
 673   (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _)
 674        = inst_ty1 == inst_ty2 && dfun1 == dfun2
 675 \end{code}
 676
 677
 678 %************************************************************************
 679 %*                                                                      *
 680 \subsection[DefaultDecl]{A @default@ declaration}
 681 %*                                                                      *
 682 %************************************************************************
 683
 684 There can only be one default declaration per module, but it is hard
 685 for the parser to check that; we pass them all through in the abstract
 686 syntax, and that restriction must be checked in the front end.
 687
 688 \begin{code}
 689 data DefaultDecl name
 690   = DefaultDecl [HsType name]
 691                 SrcLoc
 692
 693 instance (OutputableBndr name)
 694               => Outputable (DefaultDecl name) where
 695
 696     ppr (DefaultDecl tys src_loc)
 697       = ptext SLIT("default") <+> parens (interpp'SP tys)
 698 \end{code}
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsection{Foreign function interface declaration}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 \begin{code}
 707
 708 -- foreign declarations are distinguished as to whether they define or use a
 709 -- Haskell name
 710 --
 711 -- * the Boolean value indicates whether the pre-standard deprecated syntax
 712 --   has been used
 713 --
 714 data ForeignDecl name
 715   = ForeignImport name (HsType name) ForeignImport Bool SrcLoc  -- defines name
 716   | ForeignExport name (HsType name) ForeignExport Bool SrcLoc  -- uses name
 717
 718 -- yield the Haskell name defined or used in a foreign declaration
 719 --
 720 foreignDeclName                           :: ForeignDecl name -> name
 721 foreignDeclName (ForeignImport n _ _ _ _)  = n
 722 foreignDeclName (ForeignExport n _ _ _ _)  = n
 723
 724 -- specification of an imported external entity in dependence on the calling
 725 -- convention
 726 --
 727 data ForeignImport = -- import of a C entity
 728                      --
 729                      -- * the two strings specifying a header file or library
 730                      --   may be empty, which indicates the absence of a
 731                      --   header or object specification (both are not used
 732                      --   in the case of `CWrapper' and when `CFunction'
 733                      --   has a dynamic target)
 734                      --
 735                      -- * the calling convention is irrelevant for code
 736                      --   generation in the case of `CLabel', but is needed
 737                      --   for pretty printing
 738                      --
 739                      -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
 740                      --
 741                      CImport  CCallConv       -- ccall or stdcall
 742                               Safety          -- safe or unsafe
 743                               FastString      -- name of C header
 744                               FastString      -- name of library object
 745                               CImportSpec     -- details of the C entity
 746
 747                      -- import of a .NET function
 748                      --
 749                    | DNImport DNCallSpec
 750
 751 -- details of an external C entity
 752 --
 753 data CImportSpec = CLabel    CLabelString     -- import address of a C label
 754                  | CFunction CCallTarget      -- static or dynamic function
 755                  | CWrapper                   -- wrapper to expose closures
 756                                               -- (former f.e.d.)
 757
 758 -- specification of an externally exported entity in dependence on the calling
 759 -- convention
 760 --
 761 data ForeignExport = CExport  CExportSpec    -- contains the calling convention
 762                    | DNExport                -- presently unused
 763
 764 -- abstract type imported from .NET
 765 --
 766 data FoType = DNType            -- In due course we'll add subtype stuff
 767             deriving (Eq)       -- Used for equality instance for TyClDecl
 768
 769
 770 -- pretty printing of foreign declarations
 771 --
 772
 773 instance OutputableBndr name => Outputable (ForeignDecl name) where
 774   ppr (ForeignImport n ty fimport _ _) =
 775     ptext SLIT("foreign import") <+> ppr fimport <+>
 776     ppr n <+> dcolon <+> ppr ty
 777   ppr (ForeignExport n ty fexport _ _) =
 778     ptext SLIT("foreign export") <+> ppr fexport <+>
 779     ppr n <+> dcolon <+> ppr ty
 780
 781 instance Outputable ForeignImport where
 782   ppr (DNImport                         spec) =
 783     ptext SLIT("dotnet") <+> ppr spec
 784   ppr (CImport  cconv safety header lib spec) =
 785     ppr cconv <+> ppr safety <+>
 786     char '"' <> pprCEntity header lib spec <> char '"'
 787     where
 788       pprCEntity header lib (CLabel lbl) =
 789         ptext SLIT("static") <+> ftext header <+> char '&' <>
 790         pprLib lib <> ppr lbl
 791       pprCEntity header lib (CFunction (StaticTarget lbl)) =
 792         ptext SLIT("static") <+> ftext header <+> char '&' <>
 793         pprLib lib <> ppr lbl
 794       pprCEntity header lib (CFunction (DynamicTarget)) =
 795         ptext SLIT("dynamic")
 796       pprCEntity header lib (CFunction (CasmTarget _)) =
 797         panic "HsDecls.pprCEntity: malformed C function target"
 798       pprCEntity _      _   (CWrapper) = ptext SLIT("wrapper")
 799       --
 800       pprLib lib | nullFastString lib = empty
 801                  | otherwise          = char '[' <> ppr lib <> char ']'
 802
 803 instance Outputable ForeignExport where
 804   ppr (CExport  (CExportStatic lbl cconv)) =
 805     ppr cconv <+> char '"' <> ppr lbl <> char '"'
 806   ppr (DNExport                          ) =
 807     ptext SLIT("dotnet") <+> ptext SLIT("\"<unused>\"")
 808
 809 instance Outputable FoType where
 810   ppr DNType = ptext SLIT("type dotnet")
 811 \end{code}
 812
 813
 814 %************************************************************************
 815 %*                                                                      *
 816 \subsection{Transformation rules}
 817 %*                                                                      *
 818 %************************************************************************
 819
 820 \begin{code}
 821 data RuleDecl name
 822   = HsRule                      -- Source rule
 823         RuleName                -- Rule name
 824         Activation
 825         [RuleBndr name]         -- Forall'd vars; after typechecking this includes tyvars
 826         (HsExpr name)   -- LHS
 827         (HsExpr name)   -- RHS
 828         SrcLoc
 829
 830   | IfaceRule                   -- One that's come in from an interface file; pre-typecheck
 831         RuleName
 832         Activation
 833         [UfBinder name]         -- Tyvars and term vars
 834         name                    -- Head of lhs
 835         [UfExpr name]           -- Args of LHS
 836         (UfExpr name)           -- Pre typecheck
 837         SrcLoc
 838
 839   | IfaceRuleOut                -- Post typecheck
 840         name                    -- Head of LHS
 841         CoreRule
 842
 843 isSrcRule (HsRule _ _ _ _ _ _) = True
 844 isSrcRule other                = False
 845
 846 ifaceRuleDeclName :: RuleDecl name -> name
 847 ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
 848 ifaceRuleDeclName (IfaceRuleOut n r)        = n
 849 ifaceRuleDeclName (HsRule fs _ _ _ _ _)     = pprPanic "ifaceRuleDeclName" (ppr fs)
 850
 851 data RuleBndr name
 852   = RuleBndr name
 853   | RuleBndrSig name (HsType name)
 854
 855 collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
 856 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 857
 858 instance (NamedThing name, Ord name) => Eq (RuleDecl name) where
 859   -- Works for IfaceRules only; used when comparing interface file versions
 860   (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
 861      = n1==n2 && f1 == f2 && a1==a2 &&
 862        eq_ufBinders emptyEqHsEnv bs1 bs2 (\env ->
 863        eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
 864
 865 instance OutputableBndr name => Outputable (RuleDecl name) where
 866   ppr (HsRule name act ns lhs rhs loc)
 867         = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
 868                pp_forall, pprExpr lhs, equals <+> pprExpr rhs,
 869                text "#-}" ]
 870         where
 871           pp_forall | null ns   = empty
 872                     | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
 873
 874   ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc)
 875     = hsep [ doubleQuotes (ftext name), ppr act,
 876            ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
 877            ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
 878            ptext SLIT("=") <+> ppr rhs
 879       ] <+> semi
 880
 881   ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule
 882
 883 instance OutputableBndr name => Outputable (RuleBndr name) where
 884    ppr (RuleBndr name) = ppr name
 885    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 886 \end{code}
 887
 888
 889 %************************************************************************
 890 %*                                                                      *
 891 \subsection[DeprecDecl]{Deprecations}
 892 %*                                                                      *
 893 %************************************************************************
 894
 895 We use exported entities for things to deprecate.
 896
 897 \begin{code}
 898 data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
 899
 900 type DeprecTxt = FastString     -- reason/explanation for deprecation
 901
 902 instance OutputableBndr name => Outputable (DeprecDecl name) where
 903     ppr (Deprecation thing txt _)
 904       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 905 \end{code}
 906
 907
 908 %************************************************************************
 909 %*                                                                      *
 910                 External-core declarations
 911 %*                                                                      *
 912 %************************************************************************
 913
 914 \begin{code}
 915 data CoreDecl name      -- a Core value binding (from 'external Core' input)
 916   = CoreDecl    name
 917                 (HsType name)
 918                 (UfExpr name)
 919                 SrcLoc
 920
 921 instance OutputableBndr name => Outputable (CoreDecl name) where
 922     ppr (CoreDecl var ty rhs loc)
 923         = getPprStyle $ \ sty ->
 924           hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ]
 925 \end{code}