ghc/compiler/hsSyn/HsDecls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[HsDecls]{Abstract syntax: global declarations}
   5
   6 Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
   7 @InstDecl@, @DefaultDecl@.
   8
   9 \begin{code}
  10 module HsDecls where
  11
  12 #include "HsVersions.h"
  13
  14 -- friends:
  15 import HsBinds          ( HsBinds, MonoBinds, Sig, nullMonoBinds )
  16 import HsPragmas        ( DataPragmas, ClassPragmas,
  17                           InstancePragmas, ClassOpPragmas
  18                         )
  19 import HsTypes
  20 import HsCore           ( UfExpr )
  21 import BasicTypes       ( Fixity, NewOrData(..) )
  22 import IdInfo           ( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
  23 import Demand           ( Demand )
  24
  25 -- others:
  26 import Name             ( getOccName, OccName, NamedThing(..) )
  27 import Outputable
  28 import SrcLoc           ( SrcLoc )
  29 import Util
  30 \end{code}
  31
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection[HsDecl]{Declarations}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 \begin{code}
  40 data HsDecl flexi name pat
  41   = TyD         (TyDecl name)
  42   | ClD         (ClassDecl flexi name pat)
  43   | InstD       (InstDecl  flexi name pat)
  44   | DefD        (DefaultDecl name)
  45   | ValD        (HsBinds flexi name pat)
  46   | SigD        (IfaceSig name)
  47 \end{code}
  48
  49 \begin{code}
  50 #ifdef DEBUG
  51 hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
  52            => HsDecl flexi name pat -> name
  53 #endif
  54 hsDeclName (TyD (TyData _ _ name _ _ _ _ _))      = name
  55 hsDeclName (TyD (TySynonym name _ _ _))           = name
  56 hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
  57 hsDeclName (SigD (IfaceSig name _ _ _))           = name
  58 hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
  59 -- Others don't make sense
  60 #ifdef DEBUG
  61 hsDeclName x                                  = pprPanic "HsDecls.hsDeclName" (ppr x)
  62 #endif
  63 \end{code}
  64
  65 \begin{code}
  66 instance (NamedThing name, Outputable name, Outputable pat)
  67         => Outputable (HsDecl flexi name pat) where
  68
  69     ppr (TyD td)     = ppr td
  70     ppr (ClD cd)     = ppr cd
  71     ppr (SigD sig)   = ppr sig
  72     ppr (ValD binds) = ppr binds
  73     ppr (DefD def)   = ppr def
  74     ppr (InstD inst) = ppr inst
  75
  76 #ifdef DEBUG
  77 -- hsDeclName needs more context when DEBUG is on
  78 instance (NamedThing name, Outputable name, Outputable pat, Eq name)
  79       => Eq (HsDecl flex name pat) where
  80    d1 == d2 = hsDeclName d1 == hsDeclName d2
  81
  82 instance (NamedThing name, Outputable name, Outputable pat, Ord name)
  83       => Ord (HsDecl flex name pat) where
  84         d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
  85 #else
  86 instance (Eq name) => Eq (HsDecl flex name pat) where
  87         d1 == d2 = hsDeclName d1 == hsDeclName d2
  88
  89 instance (Ord name) => Ord (HsDecl flexi name pat) where
  90         d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
  91 #endif
  92 \end{code}
  93
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection[FixityDecl]{A fixity declaration}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102 data FixityDecl name  = FixityDecl name Fixity SrcLoc
 103
 104 instance Outputable name => Outputable (FixityDecl name) where
 105   ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
 106 \end{code}
 107
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \begin{code}
 116 data TyDecl name
 117   = TyData      NewOrData
 118                 (Context name)  -- context
 119                 name            -- type constructor
 120                 [HsTyVar name]  -- type variables
 121                 [ConDecl name]  -- data constructors (empty if abstract)
 122                 (Maybe [name])  -- derivings; Nothing => not specified
 123                                 -- (i.e., derive default); Just [] => derive
 124                                 -- *nothing*; Just <list> => as you would
 125                                 -- expect...
 126                 (DataPragmas name)
 127                 SrcLoc
 128
 129   | TySynonym   name            -- type constructor
 130                 [HsTyVar name]  -- type variables
 131                 (HsType name)   -- synonym expansion
 132                 SrcLoc
 133
 134 \end{code}
 135
 136 \begin{code}
 137 instance (NamedThing name, Outputable name)
 138               => Outputable (TyDecl name) where
 139
 140     ppr (TySynonym tycon tyvars mono_ty src_loc)
 141       = hang (pp_decl_head SLIT("type") empty tycon tyvars)
 142              4 (ppr mono_ty)
 143
 144     ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
 145       = pp_tydecl
 146                   (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars)
 147                   (pp_condecls condecls)
 148                   derivings
 149       where
 150         keyword = case new_or_data of
 151                         NewType  -> SLIT("newtype")
 152                         DataType -> SLIT("data")
 153
 154 pp_decl_head str pp_context tycon tyvars
 155   = hsep [ptext str, pp_context, ppr tycon,
 156            interppSP tyvars, ptext SLIT("=")]
 157
 158 pp_condecls [] = empty          -- Curious!
 159 pp_condecls (c:cs)
 160   = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs)
 161
 162 pp_tydecl pp_head pp_decl_rhs derivings
 163   = hang pp_head 4 (sep [
 164         pp_decl_rhs,
 165         case derivings of
 166           Nothing          -> empty
 167           Just ds          -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
 168     ])
 169
 170 pp_context_and_arrow :: Outputable name => Context name -> SDoc
 171 pp_context_and_arrow [] = empty
 172 pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
 173 \end{code}
 174
 175 A type for recording what types a datatype should be specialised to.
 176 It's called a ``Sig'' because it's sort of like a ``type signature''
 177 for an datatype declaration.
 178
 179 \begin{code}
 180 data SpecDataSig name
 181   = SpecDataSig name            -- tycon to specialise
 182                 (HsType name)
 183                 SrcLoc
 184
 185 instance (NamedThing name, Outputable name)
 186               => Outputable (SpecDataSig name) where
 187
 188     ppr (SpecDataSig tycon ty _)
 189       = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
 190 \end{code}
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[ConDecl]{A data-constructor declaration}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 \begin{code}
 199 data ConDecl name
 200   = ConDecl     name                    -- Constructor name
 201                 (Context name)          -- Existential context for this constructor
 202                 (ConDetails name)
 203                 SrcLoc
 204
 205 data ConDetails name
 206   = VanillaCon                  -- prefix-style con decl
 207                 [BangType name]
 208
 209   | InfixCon                    -- infix-style con decl
 210                 (BangType name)
 211                 (BangType name)
 212
 213   | RecCon                      -- record-style con decl
 214                 [([name], BangType name)]       -- list of "fields"
 215
 216   | NewCon                      -- newtype con decl
 217                 (HsType name)
 218
 219 data BangType name
 220   = Banged   (HsType name)      -- HsType: to allow Haskell extensions
 221   | Unbanged (HsType name)      -- (MonoType only needed for straight Haskell)
 222 \end{code}
 223
 224 \begin{code}
 225 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 226     ppr (ConDecl con cxt con_details  loc)
 227       = pp_context_and_arrow cxt <+> ppr_con_details con con_details
 228
 229 ppr_con_details con (InfixCon ty1 ty2)
 230   = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
 231
 232 ppr_con_details con (VanillaCon tys)
 233   = ppr con <+> hsep (map (ppr_bang) tys)
 234
 235 ppr_con_details con (NewCon ty)
 236   = ppr con <+> pprParendHsType ty
 237
 238 ppr_con_details con (RecCon fields)
 239   = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
 240   where
 241     ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
 242                          ptext SLIT("::") <+>
 243                          ppr_bang ty
 244
 245 ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
 246 ppr_bang (Unbanged ty) = pprParendHsType ty
 247 \end{code}
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection[ClassDecl]{A class declaration}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 data ClassDecl flexi name pat
 257   = ClassDecl   (Context name)                  -- context...
 258                 name                            -- name of the class
 259                 [HsTyVar name]                  -- the class type variables
 260                 [Sig name]                      -- methods' signatures
 261                 (MonoBinds flexi name pat)      -- default methods
 262                 (ClassPragmas name)
 263                 name name                       -- The names of the tycon and datacon for this class
 264                                                 -- These are filled in by the renamer
 265                 SrcLoc
 266 \end{code}
 267
 268 \begin{code}
 269 instance (NamedThing name, Outputable name, Outputable pat)
 270                 => Outputable (ClassDecl flexi name pat) where
 271
 272     ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
 273       | null sigs       -- No "where" part
 274       = top_matter
 275
 276       | otherwise       -- Laid out
 277       = sep [hsep [top_matter, ptext SLIT("where {")],
 278                nest 4 (vcat [sep (map ppr_sig sigs),
 279                                    ppr methods,
 280                                    char '}'])]
 281       where
 282         top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context,
 283                             ppr clas, hsep (map (ppr) tyvars)]
 284         ppr_sig sig = ppr sig <> semi
 285 \end{code}
 286
 287 %************************************************************************
 288 %*                                                                      *
 289 \subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 \begin{code}
 294 data InstDecl flexi name pat
 295   = InstDecl    (HsType name)   -- Context => Class Instance-type
 296                                 -- Using a polytype means that the renamer conveniently
 297                                 -- figures out the quantified type variables for us.
 298
 299                 (MonoBinds flexi name pat)
 300
 301                 [Sig name]              -- User-supplied pragmatic info
 302
 303                 (Maybe name)            -- Name for the dictionary function
 304
 305                 SrcLoc
 306 \end{code}
 307
 308 \begin{code}
 309 instance (NamedThing name, Outputable name, Outputable pat)
 310               => Outputable (InstDecl flexi name pat) where
 311
 312     ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
 313       = getPprStyle $ \ sty ->
 314         if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
 315            hsep [ptext SLIT("instance"), ppr inst_ty]
 316         else
 317            vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
 318                  nest 4 (ppr uprags),
 319                  nest 4 (ppr binds) ]
 320 \end{code}
 321
 322 A type for recording what instances the user wants to specialise;
 323 called a ``Sig'' because it's sort of like a ``type signature'' for an
 324 instance.
 325 \begin{code}
 326 data SpecInstSig name
 327   = SpecInstSig  name               -- class
 328                  (HsType name)    -- type to specialise to
 329                  SrcLoc
 330
 331 instance (NamedThing name, Outputable name)
 332               => Outputable (SpecInstSig name) where
 333
 334     ppr (SpecInstSig clas ty _)
 335       = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"]
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[DefaultDecl]{A @default@ declaration}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 There can only be one default declaration per module, but it is hard
 345 for the parser to check that; we pass them all through in the abstract
 346 syntax, and that restriction must be checked in the front end.
 347
 348 \begin{code}
 349 data DefaultDecl name
 350   = DefaultDecl [HsType name]
 351                 SrcLoc
 352
 353 instance (NamedThing name, Outputable name)
 354               => Outputable (DefaultDecl name) where
 355
 356     ppr (DefaultDecl tys src_loc)
 357       = ptext SLIT("default") <+> parens (interpp'SP tys)
 358 \end{code}
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection{Signatures in interface files}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 \begin{code}
 367 data IfaceSig name
 368   = IfaceSig    name
 369                 (HsType name)
 370                 [HsIdInfo name]
 371                 SrcLoc
 372
 373 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
 374     ppr (IfaceSig var ty _ _)
 375       = hang (hsep [ppr var, ptext SLIT("::")])
 376              4 (ppr ty)
 377
 378 data HsIdInfo name
 379   = HsArity             ArityInfo
 380   | HsStrictness        (HsStrictnessInfo name)
 381   | HsUnfold            Bool (UfExpr name)      -- True <=> INLINE pragma
 382   | HsUpdate            UpdateInfo
 383   | HsArgUsage          ArgUsageInfo
 384   | HsFBType            FBTypeInfo
 385         -- ToDo: specialisations
 386
 387 data HsStrictnessInfo name
 388   = HsStrictnessInfo [Demand]
 389                      (Maybe (name, [name]))     -- Worker, if any
 390                                                 -- and needed constructors
 391   | HsBottom
 392 \end{code}