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