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 ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
 302 ppr_bang (Unbanged ty) = pprParendHsType ty
 303 ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
 304 \end{code}
 305
 306
 307 %************************************************************************
 308 %*                                                                      *
 309 \subsection[InstDecl]{An instance declaration
 310 %*                                                                      *
 311 %************************************************************************
 312
 313 \begin{code}
 314 data InstDecl name pat
 315   = InstDecl    (HsType name)   -- Context => Class Instance-type
 316                                 -- Using a polytype means that the renamer conveniently
 317                                 -- figures out the quantified type variables for us.
 318
 319                 (MonoBinds name pat)
 320
 321                 [Sig name]              -- User-supplied pragmatic info
 322
 323                 name                    -- Name for the dictionary function
 324
 325                 SrcLoc
 326 \end{code}
 327
 328 \begin{code}
 329 instance (Outputable name, Outputable pat)
 330               => Outputable (InstDecl name pat) where
 331
 332     ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
 333       = getPprStyle $ \ sty ->
 334         if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
 335            hsep [ptext SLIT("instance"), ppr inst_ty]
 336         else
 337            vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
 338                  nest 4 (ppr uprags),
 339                  nest 4 (ppr binds) ]
 340 \end{code}
 341
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsection[DefaultDecl]{A @default@ declaration}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 There can only be one default declaration per module, but it is hard
 350 for the parser to check that; we pass them all through in the abstract
 351 syntax, and that restriction must be checked in the front end.
 352
 353 \begin{code}
 354 data DefaultDecl name
 355   = DefaultDecl [HsType name]
 356                 SrcLoc
 357
 358 instance (Outputable name)
 359               => Outputable (DefaultDecl name) where
 360
 361     ppr (DefaultDecl tys src_loc)
 362       = ptext SLIT("default") <+> parens (interpp'SP tys)
 363 \end{code}
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{Foreign function interface declaration}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 \begin{code}
 372 data ForeignDecl name =
 373    ForeignDecl
 374         name
 375         ForKind
 376         (HsType name)
 377         ExtName
 378         CallConv
 379         SrcLoc
 380
 381 instance (Outputable name)
 382               => Outputable (ForeignDecl name) where
 383
 384     ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
 385       = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
 386         ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
 387         where
 388          (ppr_imp_exp, ppr_unsafe) =
 389            case imp_exp of
 390              FoLabel     -> (ptext SLIT("label"), empty)
 391              FoExport    -> (ptext SLIT("export"), empty)
 392              FoImport us
 393                 | us        -> (ptext SLIT("import"), ptext SLIT("unsafe"))
 394                 | otherwise -> (ptext SLIT("import"), empty)
 395
 396 data ForKind
 397  = FoLabel
 398  | FoExport
 399  | FoImport Bool -- True  => unsafe call.
 400
 401 data ExtName
 402  = Dynamic
 403  | ExtName CLabelString         -- The external name of the foreign thing,
 404            (Maybe CLabelString) -- and optionally its DLL or module name
 405                                 -- Both of these are completely unencoded;
 406                                 -- we just print them as they are
 407
 408 isDynamicExtName :: ExtName -> Bool
 409 isDynamicExtName Dynamic = True
 410 isDynamicExtName _       = False
 411
 412 extNameStatic :: ExtName -> CLabelString
 413 extNameStatic (ExtName f _) = f
 414 extNameStatic Dynamic       = panic "staticExtName: Dynamic - shouldn't ever happen."
 415
 416 instance Outputable ExtName where
 417   ppr Dynamic      = ptext SLIT("dynamic")
 418   ppr (ExtName nm mb_mod) =
 419      case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
 420      doubleQuotes (pprCLabelString nm)
 421 \end{code}
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsection{Transformation rules}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 \begin{code}
 430 data RuleDecl name pat
 431   = RuleDecl
 432         FAST_STRING             -- Rule name
 433         [name]                  -- Forall'd tyvars, filled in by the renamer with
 434                                 -- tyvars mentioned in sigs; then filled out by typechecker
 435         [RuleBndr name]         -- Forall'd term vars
 436         (HsExpr name pat)       -- LHS
 437         (HsExpr name pat)       -- RHS
 438         SrcLoc
 439
 440   | IfaceRuleDecl               -- One that's come in from an interface file
 441         name
 442         (UfRuleBody name)
 443         SrcLoc
 444
 445 data RuleBndr name
 446   = RuleBndr name
 447   | RuleBndrSig name (HsType name)
 448
 449 instance (Outputable name, Outputable pat)
 450               => Outputable (RuleDecl name pat) where
 451   ppr (RuleDecl name tvs ns lhs rhs loc)
 452         = sep [text "{-# RULES" <+> doubleQuotes (ptext name),
 453                pp_forall, ppr lhs, equals <+> ppr rhs,
 454                text "#-}" ]
 455         where
 456           pp_forall | null tvs && null ns = empty
 457                     | otherwise           = text "forall" <+>
 458                                             fsep (map ppr tvs ++ map ppr ns)
 459                                             <> dot
 460   ppr (IfaceRuleDecl var body loc) = text "An imported rule..."
 461
 462 instance Outputable name => Outputable (RuleBndr name) where
 463    ppr (RuleBndr name) = ppr name
 464    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 465 \end{code}