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 #include "HsVersions.h"
  11
  12 module HsDecls where
  13
  14 IMP_Ubiq()
  15
  16 -- friends:
  17 import HsBinds          ( HsBinds, MonoBinds, Sig, nullMonoBinds )
  18 import HsPragmas        ( DataPragmas, ClassPragmas,
  19                           InstancePragmas, ClassOpPragmas
  20                         )
  21 import HsTypes
  22 import IdInfo
  23 import SpecEnv          ( SpecEnv )
  24 import HsCore           ( UfExpr )
  25 import BasicTypes       ( Fixity, NewOrData(..) )
  26
  27 -- others:
  28 import Name             ( getOccName, OccName, NamedThing(..) )
  29 import Outputable       ( interppSP, interpp'SP,
  30                           PprStyle(..), Outputable(..){-instance * []-}
  31                         )
  32 import Pretty
  33 import SrcLoc           ( SrcLoc )
  34 import Util
  35 \end{code}
  36
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[HsDecl]{Declarations}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 \begin{code}
  45 data HsDecl tyvar uvar name pat
  46   = TyD         (TyDecl name)
  47   | ClD         (ClassDecl tyvar uvar name pat)
  48   | InstD       (InstDecl  tyvar uvar name pat)
  49   | DefD        (DefaultDecl name)
  50   | ValD        (HsBinds tyvar uvar name pat)
  51   | SigD        (IfaceSig name)
  52 \end{code}
  53
  54 \begin{code}
  55 #ifdef DEBUG
  56 hsDeclName :: (NamedThing name, Outputable name, Outputable pat,
  57                Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
  58            => HsDecl tyvar uvar name pat -> name
  59 #endif
  60 hsDeclName (TyD (TyData _ _ name _ _ _ _ _))      = name
  61 hsDeclName (TyD (TySynonym name _ _ _))           = name
  62 hsDeclName (ClD (ClassDecl _ name _ _ _ _ _))     = name
  63 hsDeclName (SigD (IfaceSig name _ _ _))           = name
  64 hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
  65 -- Others don't make sense
  66 #ifdef DEBUG
  67 hsDeclName x                                  = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x)
  68 #endif
  69 \end{code}
  70
  71 \begin{code}
  72 instance (NamedThing name, Outputable name, Outputable pat,
  73           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
  74         => Outputable (HsDecl tyvar uvar name pat) where
  75
  76     ppr sty (TyD td)     = ppr sty td
  77     ppr sty (ClD cd)     = ppr sty cd
  78     ppr sty (SigD sig)   = ppr sty sig
  79     ppr sty (ValD binds) = ppr sty binds
  80     ppr sty (DefD def)   = ppr sty def
  81     ppr sty (InstD inst) = ppr sty inst
  82
  83 #ifdef DEBUG
  84 instance (Ord3 name, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
  85           NamedThing name, Outputable name, Outputable pat) =>
  86           Ord3 (HsDecl tyvar uvar name pat) where
  87 #else
  88 instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where
  89 #endif
  90   d1 `cmp` d2 = hsDeclName d1 `cmp` hsDeclName d2
  91 \end{code}
  92
  93
  94 %************************************************************************
  95 %*                                                                      *
  96 \subsection[FixityDecl]{A fixity declaration}
  97 %*                                                                      *
  98 %************************************************************************
  99
 100 \begin{code}
 101 data FixityDecl name  = FixityDecl name Fixity SrcLoc
 102
 103 instance Outputable name => Outputable (FixityDecl name) where
 104   ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name]
 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 TyDecl name
 116   = TyData      NewOrData
 117                 (Context 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 \end{code}
 134
 135 \begin{code}
 136 instance (NamedThing name, Outputable name)
 137               => Outputable (TyDecl name) where
 138
 139     ppr sty (TySynonym tycon tyvars mono_ty src_loc)
 140       = hang (pp_decl_head sty SLIT("type") empty tycon tyvars)
 141              4 (ppr sty mono_ty)
 142
 143     ppr sty (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
 144       = pp_tydecl sty
 145                   (pp_decl_head sty keyword (pp_context_and_arrow sty context) tycon tyvars)
 146                   (pp_condecls sty condecls)
 147                   derivings
 148       where
 149         keyword = case new_or_data of
 150                         NewType  -> SLIT("newtype")
 151                         DataType -> SLIT("data")
 152
 153 pp_decl_head sty str pp_context tycon tyvars
 154   = hsep [ptext str, pp_context, ppr sty tycon,
 155            interppSP sty tyvars, ptext SLIT("=")]
 156
 157 pp_condecls sty [] = empty              -- Curious!
 158 pp_condecls sty (c:cs)
 159   = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs)
 160
 161 pp_tydecl sty pp_head pp_decl_rhs derivings
 162   = hang pp_head 4 (sep [
 163         pp_decl_rhs,
 164         case (derivings, sty) of
 165           (Nothing,_)      -> empty
 166           (_,PprInterface) -> empty     -- No derivings in interfaces
 167           (Just ds,_)      -> hsep [ptext SLIT("deriving"), parens (interpp'SP sty ds)]
 168     ])
 169
 170 pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Doc
 171 pp_context_and_arrow sty [] = empty
 172 pp_context_and_arrow sty theta = hsep [pprContext sty 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 sty (SpecDataSig tycon ty _)
 189       = hsep [text "{-# SPECIALIZE data", ppr sty 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 sty (ConDecl con cxt con_details  loc)
 227       = pp_context_and_arrow sty cxt <+> ppr_con_details sty con con_details
 228
 229 ppr_con_details sty con (InfixCon ty1 ty2)
 230   = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2]
 231
 232 ppr_con_details sty con (VanillaCon tys)
 233   = ppr sty con <+> hsep (map (ppr_bang sty) tys)
 234
 235 ppr_con_details sty con (NewCon ty)
 236   = ppr sty con <+> pprParendHsType sty ty
 237
 238 ppr_con_details sty con (RecCon fields)
 239   = ppr sty con <+> braces (hsep (punctuate comma (map ppr_field fields)))
 240   where
 241     ppr_field (ns, ty) = hsep (map (ppr sty) ns) <+>
 242                          ptext SLIT("::") <+>
 243                          ppr_bang sty ty
 244
 245 ppr_bang sty (Banged   ty) = ptext SLIT("!") <> pprParendHsType sty ty
 246 ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
 247 \end{code}
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection[ClassDecl]{A class declaration}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 data ClassDecl tyvar uvar name pat
 257   = ClassDecl   (Context name)                  -- context...
 258                 name                            -- name of the class
 259                 (HsTyVar name)                  -- the class type variable
 260                 [Sig name]                      -- methods' signatures
 261                 (MonoBinds tyvar uvar name pat) -- default methods
 262                 (ClassPragmas name)
 263                 SrcLoc
 264 \end{code}
 265
 266 \begin{code}
 267 instance (NamedThing name, Outputable name, Outputable pat,
 268           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 269                 => Outputable (ClassDecl tyvar uvar name pat) where
 270
 271     ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
 272       | null sigs       -- No "where" part
 273       = top_matter
 274
 275       | otherwise       -- Laid out
 276       = sep [hsep [top_matter, ptext SLIT("where {")],
 277                nest 4 (vcat [sep (map ppr_sig sigs),
 278                                    ppr sty methods,
 279                                    char '}'])]
 280       where
 281         top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow sty context,
 282                             ppr sty clas, ppr sty tyvar]
 283         ppr_sig sig = ppr sty sig <> semi
 284 \end{code}
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 data InstDecl tyvar uvar name pat
 294   = InstDecl    (HsType name)   -- Context => Class Instance-type
 295                                 -- Using a polytype means that the renamer conveniently
 296                                 -- figures out the quantified type variables for us.
 297
 298                 (MonoBinds tyvar uvar name pat)
 299
 300                 [Sig name]              -- User-supplied pragmatic info
 301
 302                 (Maybe name)            -- Name for the dictionary function
 303
 304                 SrcLoc
 305 \end{code}
 306
 307 \begin{code}
 308 instance (NamedThing name, Outputable name, Outputable pat,
 309           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 310               => Outputable (InstDecl tyvar uvar name pat) where
 311
 312     ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
 313       | case sty of { PprInterface -> True; other -> False} ||
 314         nullMonoBinds binds && null uprags
 315       = hsep [ptext SLIT("instance"), ppr sty inst_ty]
 316
 317       | otherwise
 318       = vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")],
 319                   nest 4 (ppr sty uprags),
 320                   nest 4 (ppr sty binds) ]
 321 \end{code}
 322
 323 A type for recording what instances the user wants to specialise;
 324 called a ``Sig'' because it's sort of like a ``type signature'' for an
 325 instance.
 326 \begin{code}
 327 data SpecInstSig name
 328   = SpecInstSig  name               -- class
 329                  (HsType name)    -- type to specialise to
 330                  SrcLoc
 331
 332 instance (NamedThing name, Outputable name)
 333               => Outputable (SpecInstSig name) where
 334
 335     ppr sty (SpecInstSig clas ty _)
 336       = hsep [text "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, text "#-}"]
 337 \end{code}
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsection[DefaultDecl]{A @default@ declaration}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 There can only be one default declaration per module, but it is hard
 346 for the parser to check that; we pass them all through in the abstract
 347 syntax, and that restriction must be checked in the front end.
 348
 349 \begin{code}
 350 data DefaultDecl name
 351   = DefaultDecl [HsType name]
 352                 SrcLoc
 353
 354 instance (NamedThing name, Outputable name)
 355               => Outputable (DefaultDecl name) where
 356
 357     ppr sty (DefaultDecl tys src_loc)
 358       = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys))
 359 \end{code}
 360
 361 %************************************************************************
 362 %*                                                                      *
 363 \subsection{Signatures in interface files}
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 data IfaceSig name
 369   = IfaceSig    name
 370                 (HsType name)
 371                 [HsIdInfo name]
 372                 SrcLoc
 373
 374 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
 375     ppr sty (IfaceSig var ty _ _)
 376       = hang (hsep [ppr sty var, ptext SLIT("::")])
 377              4 (ppr sty ty)
 378
 379 data HsIdInfo name
 380   = HsArity             ArityInfo
 381   | HsStrictness        (HsStrictnessInfo name)
 382   | HsUnfold            Bool (UfExpr name)      -- True <=> INLINE pragma
 383   | HsUpdate            UpdateInfo
 384   | HsArgUsage          ArgUsageInfo
 385   | HsFBType            FBTypeInfo
 386         -- ToDo: specialisations
 387
 388 data HsStrictnessInfo name
 389   = HsStrictnessInfo [Demand]
 390                      (Maybe (name, [name]))     -- Worker, if any
 391                                                 -- and needed constructors
 392   | HsBottom
 393 \end{code}