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