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 @ConDecl@, @ClassDecl@,
   7 @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
   8
   9 \begin{code}
  10 module HsDecls (
  11         HsDecl(..), TyClDecl(..), InstDecl(..),
  12         DefaultDecl(..), ForeignDecl(..), ForKind(..),
  13         ExtName(..), isDynamic,
  14         ConDecl(..), ConDetails(..), BangType(..),
  15         IfaceSig(..),  SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
  16         hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 -- friends:
  22 import HsBinds          ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
  23 import HsPragmas        ( DataPragmas, ClassPragmas )
  24 import HsTypes
  25 import HsCore           ( UfExpr )
  26 import BasicTypes       ( Fixity, NewOrData(..) )
  27 import IdInfo           ( ArityInfo, UpdateInfo, InlinePragInfo )
  28 import Demand           ( Demand )
  29 import CallConv         ( CallConv, pprCallConv )
  30
  31 -- others:
  32 import Name             ( NamedThing )
  33 import Outputable
  34 import SrcLoc           ( SrcLoc )
  35 import Util
  36 \end{code}
  37
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection[HsDecl]{Declarations}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 data HsDecl name pat
  47   = TyClD       (TyClDecl name pat)
  48   | InstD       (InstDecl  name pat)
  49   | DefD        (DefaultDecl name)
  50   | ValD        (HsBinds name pat)
  51   | ForD        (ForeignDecl name)
  52   | SigD        (IfaceSig name)
  53   | FixD        (FixitySig name)
  54
  55 -- NB: all top-level fixity decls are contained EITHER
  56 -- EITHER FixDs
  57 -- OR     in the ClassDecls in TyClDs
  58 --
  59 -- The former covers
  60 --      a) data constructors
  61 --      b) class methods (but they can be also done in the
  62 --              signatures of class decls)
  63 --      c) imported functions (that have an IfacSig)
  64 --      d) top level decls
  65 --
  66 -- The latter is for class methods only
  67
  68 -- It's a bit wierd that the fixity decls in the ValD
  69 -- cover all the classops and imported decls too, but it's convenient
  70 -- For a start, it means we don't need a FixD
  71 \end{code}
  72
  73 \begin{code}
  74 #ifdef DEBUG
  75 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
  76            => HsDecl name pat -> name
  77 #endif
  78 hsDeclName (TyClD decl)                             = tyClDeclName decl
  79 hsDeclName (SigD  (IfaceSig name _ _ _))            = name
  80 hsDeclName (InstD (InstDecl _ _ _ (Just name) _))   = name
  81 hsDeclName (ForD  (ForeignDecl name _ _ _ _ _))     = name
  82 hsDeclName (FixD  (FixitySig name _ _))             = name
  83 -- Others don't make sense
  84 #ifdef DEBUG
  85 hsDeclName x                                  = pprPanic "HsDecls.hsDeclName" (ppr x)
  86 #endif
  87
  88 tyClDeclName :: TyClDecl name pat -> name
  89 tyClDeclName (TyData _ _ name _ _ _ _ _)      = name
  90 tyClDeclName (TySynonym name _ _ _)           = name
  91 tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name
  92 \end{code}
  93
  94 \begin{code}
  95 instance (NamedThing name, Outputable name, Outputable pat)
  96         => Outputable (HsDecl name pat) where
  97
  98     ppr (TyClD dcl)  = ppr dcl
  99     ppr (SigD sig)   = ppr sig
 100     ppr (ValD binds) = ppr binds
 101     ppr (DefD def)   = ppr def
 102     ppr (InstD inst) = ppr inst
 103     ppr (ForD fd)    = ppr fd
 104     ppr (FixD fd)    = ppr fd
 105
 106 {-      Why do we need ordering on decls?
 107
 108 #ifdef DEBUG
 109 -- hsDeclName needs more context when DEBUG is on
 110 instance (NamedThing name, Outputable name, Outputable pat, Eq name)
 111       => Eq (HsDecl name pat) where
 112    d1 == d2 = hsDeclName d1 == hsDeclName d2
 113
 114 instance (NamedThing name, Outputable name, Outputable pat, Ord name)
 115       => Ord (HsDecl name pat) where
 116         d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
 117 #else
 118 instance (Eq name) => Eq (HsDecl name pat) where
 119         d1 == d2 = hsDeclName d1 == hsDeclName d2
 120
 121 instance (Ord name) => Ord (HsDecl name pat) where
 122         d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
 123 #endif
 124 -}
 125 \end{code}
 126
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 data TyClDecl name pat
 136   = TyData      NewOrData
 137                 (Context name)  -- context
 138                 name            -- type constructor
 139                 [HsTyVar name]  -- type variables
 140                 [ConDecl name]  -- data constructors (empty if abstract)
 141                 (Maybe [name])  -- derivings; Nothing => not specified
 142                                 -- (i.e., derive default); Just [] => derive
 143                                 -- *nothing*; Just <list> => as you would
 144                                 -- expect...
 145                 (DataPragmas name)
 146                 SrcLoc
 147
 148   | TySynonym   name            -- type constructor
 149                 [HsTyVar name]  -- type variables
 150                 (HsType name)   -- synonym expansion
 151                 SrcLoc
 152
 153   | ClassDecl   (Context name)                  -- context...
 154                 name                            -- name of the class
 155                 [HsTyVar name]                  -- the class type variables
 156                 [Sig name]                      -- methods' signatures
 157                 (MonoBinds name pat)    -- default methods
 158                 (ClassPragmas name)
 159                 name name                       -- The names of the tycon and datacon for this class
 160                                                 -- These are filled in by the renamer
 161                 SrcLoc
 162 \end{code}
 163
 164 \begin{code}
 165 countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
 166         -- class, data, newtype, synonym decls
 167 countTyClDecls decls
 168  = (length [() | ClassDecl _ _ _ _ _ _ _ _   _ <- decls],
 169     length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
 170     length [() | TyData NewType  _ _ _ _ _ _ _ <- decls],
 171     length [() | TySynonym _ _ _ _             <- decls])
 172
 173 isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
 174
 175 isSynDecl (TySynonym _ _ _ _) = True
 176 isSynDecl other               = False
 177
 178 isDataDecl (TyData _ _ _ _ _ _ _ _) = True
 179 isDataDecl other                    = False
 180
 181 isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
 182 isClassDecl other                         = False
 183 \end{code}
 184
 185 \begin{code}
 186 instance (NamedThing name, Outputable name, Outputable pat)
 187               => Outputable (TyClDecl name pat) where
 188
 189     ppr (TySynonym tycon tyvars mono_ty src_loc)
 190       = hang (pp_decl_head SLIT("type") empty tycon tyvars)
 191              4 (ppr mono_ty)
 192
 193     ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
 194       = pp_tydecl
 195                   (pp_decl_head keyword (pprContext context) tycon tyvars)
 196                   (pp_condecls condecls)
 197                   derivings
 198       where
 199         keyword = case new_or_data of
 200                         NewType  -> SLIT("newtype")
 201                         DataType -> SLIT("data")
 202
 203     ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
 204       | null sigs       -- No "where" part
 205       = top_matter
 206
 207       | otherwise       -- Laid out
 208       = sep [hsep [top_matter, ptext SLIT("where {")],
 209                nest 4 (vcat [sep (map ppr_sig sigs),
 210                                    ppr methods,
 211                                    char '}'])]
 212       where
 213         top_matter = hsep [ptext SLIT("class"), pprContext context,
 214                             ppr clas, hsep (map (ppr) tyvars)]
 215         ppr_sig sig = ppr sig <> semi
 216
 217
 218 pp_decl_head str pp_context tycon tyvars
 219   = hsep [ptext str, pp_context, ppr tycon,
 220            interppSP tyvars, ptext SLIT("=")]
 221
 222 pp_condecls []     = empty              -- Curious!
 223 pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
 224
 225 pp_tydecl pp_head pp_decl_rhs derivings
 226   = hang pp_head 4 (sep [
 227         pp_decl_rhs,
 228         case derivings of
 229           Nothing          -> empty
 230           Just ds          -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
 231     ])
 232 \end{code}
 233
 234 A type for recording what types a datatype should be specialised to.
 235 It's called a ``Sig'' because it's sort of like a ``type signature''
 236 for an datatype declaration.
 237
 238 \begin{code}
 239 data SpecDataSig name
 240   = SpecDataSig name            -- tycon to specialise
 241                 (HsType name)
 242                 SrcLoc
 243
 244 instance (NamedThing name, Outputable name)
 245               => Outputable (SpecDataSig name) where
 246
 247     ppr (SpecDataSig tycon ty _)
 248       = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
 249 \end{code}
 250
 251 %************************************************************************
 252 %*                                                                      *
 253 \subsection[ConDecl]{A data-constructor declaration}
 254 %*                                                                      *
 255 %************************************************************************
 256
 257 \begin{code}
 258 data ConDecl name
 259   = ConDecl     name                    -- Constructor name
 260
 261                 [HsTyVar name]          -- Existentially quantified type variables
 262                 (Context name)          -- ...and context
 263                                         -- If both are empty then there are no existentials
 264
 265                 (ConDetails name)
 266                 SrcLoc
 267
 268 data ConDetails name
 269   = VanillaCon                  -- prefix-style con decl
 270                 [BangType name]
 271
 272   | InfixCon                    -- infix-style con decl
 273                 (BangType name)
 274                 (BangType name)
 275
 276   | RecCon                      -- record-style con decl
 277                 [([name], BangType name)]       -- list of "fields"
 278
 279   | NewCon                      -- newtype con decl, possibly with a labelled field.
 280                 (HsType name)
 281                 (Maybe name)    -- Just x => labelled field 'x'
 282
 283 data BangType name
 284   = Banged   (HsType name)      -- HsType: to allow Haskell extensions
 285   | Unbanged (HsType name)      -- (MonoType only needed for straight Haskell)
 286 \end{code}
 287
 288 \begin{code}
 289 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 290     ppr (ConDecl con tvs cxt con_details  loc)
 291       = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
 292
 293 ppr_con_details con (InfixCon ty1 ty2)
 294   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 295
 296 ppr_con_details con (VanillaCon tys)
 297   = ppr con <+> hsep (map (ppr_bang) tys)
 298
 299 ppr_con_details con (NewCon ty Nothing)
 300   = ppr con <+> pprParendHsType ty
 301
 302 ppr_con_details con (NewCon ty (Just x))
 303   = ppr con <+> braces pp_field
 304    where
 305     pp_field = ppr x <+> dcolon <+> pprParendHsType ty
 306
 307 ppr_con_details con (RecCon fields)
 308   = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
 309   where
 310     ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
 311                          dcolon <+>
 312                          ppr_bang ty
 313
 314 ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
 315 ppr_bang (Unbanged ty) = pprParendHsType ty
 316 \end{code}
 317
 318
 319 %************************************************************************
 320 %*                                                                      *
 321 \subsection[InstDecl]{An instance declaration
 322 %*                                                                      *
 323 %************************************************************************
 324
 325 \begin{code}
 326 data InstDecl name pat
 327   = InstDecl    (HsType name)   -- Context => Class Instance-type
 328                                 -- Using a polytype means that the renamer conveniently
 329                                 -- figures out the quantified type variables for us.
 330
 331                 (MonoBinds name pat)
 332
 333                 [Sig name]              -- User-supplied pragmatic info
 334
 335                 (Maybe name)            -- Name for the dictionary function
 336
 337                 SrcLoc
 338 \end{code}
 339
 340 \begin{code}
 341 instance (NamedThing name, Outputable name, Outputable pat)
 342               => Outputable (InstDecl name pat) where
 343
 344     ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
 345       = getPprStyle $ \ sty ->
 346         if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
 347            hsep [ptext SLIT("instance"), ppr inst_ty]
 348         else
 349            vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
 350                  nest 4 (ppr uprags),
 351                  nest 4 (ppr binds) ]
 352 \end{code}
 353
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsection[DefaultDecl]{A @default@ declaration}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 There can only be one default declaration per module, but it is hard
 362 for the parser to check that; we pass them all through in the abstract
 363 syntax, and that restriction must be checked in the front end.
 364
 365 \begin{code}
 366 data DefaultDecl name
 367   = DefaultDecl [HsType name]
 368                 SrcLoc
 369
 370 instance (NamedThing name, Outputable name)
 371               => Outputable (DefaultDecl name) where
 372
 373     ppr (DefaultDecl tys src_loc)
 374       = ptext SLIT("default") <+> parens (interpp'SP tys)
 375 \end{code}
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection{Foreign function interface declaration}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 data ForeignDecl name =
 385    ForeignDecl
 386         name
 387         ForKind
 388         (HsType name)
 389         ExtName
 390         CallConv
 391         SrcLoc
 392
 393 instance (NamedThing name, Outputable name)
 394               => Outputable (ForeignDecl name) where
 395
 396     ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
 397       = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
 398         ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
 399         where
 400          (ppr_imp_exp, ppr_unsafe) =
 401            case imp_exp of
 402              FoLabel     -> (ptext SLIT("label"), empty)
 403              FoExport    -> (ptext SLIT("export"), empty)
 404              FoImport us
 405                 | us        -> (ptext SLIT("import"), ptext SLIT("unsafe"))
 406                 | otherwise -> (ptext SLIT("import"), empty)
 407
 408 data ForKind
 409  = FoLabel
 410  | FoExport
 411  | FoImport Bool -- True  => unsafe call.
 412
 413 data ExtName
 414  = Dynamic
 415  | ExtName FAST_STRING (Maybe FAST_STRING)
 416
 417 isDynamic :: ExtName -> Bool
 418 isDynamic Dynamic = True
 419 isDynamic _       = False
 420
 421
 422 instance Outputable ExtName where
 423   ppr Dynamic      = ptext SLIT("dynamic")
 424   ppr (ExtName nm mb_mod) =
 425      case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
 426      doubleQuotes (ptext nm)
 427
 428 \end{code}
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsection{Signatures in interface files}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436 \begin{code}
 437 data IfaceSig name
 438   = IfaceSig    name
 439                 (HsType name)
 440                 [HsIdInfo name]
 441                 SrcLoc
 442
 443 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
 444     ppr (IfaceSig var ty _ _)
 445       = hang (hsep [ppr var, dcolon])
 446              4 (ppr ty)
 447
 448 data HsIdInfo name
 449   = HsArity             ArityInfo
 450   | HsStrictness        (HsStrictnessInfo name)
 451   | HsUnfold            InlinePragInfo (Maybe (UfExpr name))
 452   | HsUpdate            UpdateInfo
 453   | HsSpecialise        [HsTyVar name] [HsType name] (UfExpr name)
 454   | HsNoCafRefs
 455
 456
 457 data HsStrictnessInfo name
 458   = HsStrictnessInfo ([Demand], Bool)
 459                      (Maybe (name, [name]))     -- Worker, if any
 460                                                 -- and needed constructors
 461   | HsBottom
 462 \end{code}