ghc/compiler/abstractSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   5
   6 Datatype for: @Binds@, @Bind@, @Sig@, @MonoBinds@.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module HsBinds where
  12
  13 import AbsUniType       ( pprUniType, TyVar, UniType
  14                           IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
  15                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  16                         )
  17 import HsExpr           ( Expr )
  18 import HsMatches        ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds )
  19 import HsPat            ( ProtoNamePat(..), RenamedPat(..),
  20                           TypecheckedPat, InPat
  21                           IF_ATTACK_PRAGMAS(COMMA typeOfPat)
  22                         )
  23 import HsPragmas        ( GenPragmas, ClassOpPragmas )
  24 import HsTypes          ( PolyType )
  25 import Id               ( Id, DictVar(..) )
  26 import IdInfo           ( UnfoldingGuidance )
  27 import Inst             ( Inst )
  28 import Name             ( Name )
  29 import Outputable
  30 import Pretty
  31 import ProtoName        ( ProtoName(..) ) -- .. for pragmas only
  32 import SrcLoc           ( SrcLoc )
  33 import Unique           ( Unique )
  34 import Util
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[AbsSyn-Binds]{Bindings: @Binds@}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 The following syntax may produce new syntax which is not part of the input,
  44 and which is instead a translation of the input to the typechecker.
  45 Syntax translations are marked TRANSLATION in comments. New empty
  46 productions are useful in development but may not appear in the final
  47 grammar.
  48
  49 Collections of bindings, created by dependency analysis and translation:
  50
  51 \begin{code}
  52 data Binds bdee pat             -- binders and bindees
  53   = EmptyBinds
  54
  55   | ThenBinds   (Binds bdee pat)
  56                 (Binds bdee pat)
  57
  58   | SingleBind  (Bind  bdee pat)
  59
  60   | BindWith            -- Bind with a type signature.
  61                         -- These appear only on typechecker input
  62                         -- (PolyType [in Sigs] can't appear on output)
  63                 (Bind bdee pat)         -- really ProtoNameBind, but...
  64                                         -- (see "really" comment below)
  65                 [Sig bdee]
  66
  67   | AbsBinds                    -- Binds abstraction; TRANSLATION
  68                 [TyVar]
  69                 [DictVar]
  70                 [(Id, Id)]              -- (old, new) pairs
  71                 [(Inst, Expr bdee pat)] -- local dictionaries
  72                 (Bind bdee pat)         -- "the business end"
  73
  74         -- Creates bindings for *new* (polymorphic, overloaded) locals
  75         -- in terms of *old* (monomorphic, non-overloaded) ones.
  76         --
  77         -- See section 9 of static semantics paper for more details.
  78         -- (You can get a PhD for explaining the True Meaning
  79         --  of this last construct.)
  80 \end{code}
  81
  82 The corresponding unparameterised synonyms:
  83
  84 \begin{code}
  85 type ProtoNameBinds     = Binds ProtoName ProtoNamePat
  86 type RenamedBinds       = Binds Name      RenamedPat
  87 type TypecheckedBinds   = Binds Id        TypecheckedPat
  88 \end{code}
  89
  90 \begin{code}
  91 nullBinds :: Binds bdee pat -> Bool
  92 nullBinds EmptyBinds            = True
  93 nullBinds (ThenBinds b1 b2)     = (nullBinds b1) && (nullBinds b2)
  94 nullBinds (SingleBind b)        = nullBind b
  95 nullBinds (BindWith b _)        = nullBind b
  96 nullBinds (AbsBinds _ _ _ ds b) = (null ds) && (nullBind b)
  97 \end{code}
  98
  99 ToDo: make this recursiveness checking also require that
 100 there be something there, i.e., not null ?
 101 \begin{code}
 102 {- UNUSED:
 103 bindsAreRecursive :: TypecheckedBinds -> Bool
 104
 105 bindsAreRecursive EmptyBinds            = False
 106 bindsAreRecursive (ThenBinds b1 b2)
 107   = (bindsAreRecursive b1) || (bindsAreRecursive b2)
 108 bindsAreRecursive (SingleBind b)        = bindIsRecursive b
 109 bindsAreRecursive (BindWith b _)        = bindIsRecursive b
 110 bindsAreRecursive (AbsBinds _ _ _ ds b)
 111   = (bindsAreRecursive d) || (bindIsRecursive b)
 112 -}
 113 \end{code}
 114
 115 \begin{code}
 116 instance (NamedThing bdee, Outputable bdee,
 117             NamedThing pat, Outputable pat) =>
 118                 Outputable (Binds bdee pat) where
 119
 120     ppr sty EmptyBinds = ppNil
 121     ppr sty (ThenBinds binds1 binds2)
 122      = ppAbove (ppr sty binds1) (ppr sty binds2)
 123     ppr sty (SingleBind bind) = ppr sty bind
 124     ppr sty (BindWith bind sigs)
 125      = ppAbove (if null sigs then ppNil else ppr sty sigs) (ppr sty bind)
 126     ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
 127      = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
 128                       ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
 129                       ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
 130                       ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
 131             (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection[AbsSyn-Sig]{@Sig@: type signatures and value-modifying user pragmas}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 141 ``specialise this function to these four types...'') in with type
 142 signatures.  Then all the machinery to move them into place, etc.,
 143 serves for both.
 144
 145 \begin{code}
 146 data Sig name
 147   = Sig         name            -- a bog-std type signature
 148                 (PolyType name)
 149                 (GenPragmas name) -- only interface ones have pragmas
 150                 SrcLoc
 151
 152   | ClassOpSig  name            -- class-op sigs have different pragmas
 153                 (PolyType name)
 154                 (ClassOpPragmas name)   -- only interface ones have pragmas
 155                 SrcLoc
 156
 157   | SpecSig     name            -- specialise a function or datatype ...
 158                 (PolyType name) -- ... to these types
 159                 (Maybe name)    -- ... maybe using this as the code for it
 160                 SrcLoc
 161
 162   | InlineSig   name              -- INLINE f [howto]
 163                 UnfoldingGuidance -- "howto": how gung-ho we are about inlining
 164                 SrcLoc
 165
 166   -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
 167   | DeforestSig name            -- Deforest using this function definition
 168                 SrcLoc
 169
 170   | MagicUnfoldingSig
 171                 name            -- Associate the "name"d function with
 172                 FAST_STRING     -- the compiler-builtin unfolding (known
 173                 SrcLoc          -- by the String name)
 174
 175 type ProtoNameSig  = Sig ProtoName
 176 type RenamedSig    = Sig Name
 177
 178 type ProtoNameClassOpSig  = Sig ProtoName
 179 type RenamedClassOpSig    = Sig Name
 180 \end{code}
 181
 182 \begin{code}
 183 instance (Outputable name) => Outputable (Sig name) where
 184     ppr sty (Sig var ty pragmas _)
 185       = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
 186              4 (ppAbove (ppr sty ty)
 187                         (ifnotPprForUser sty (ppr sty pragmas)))
 188
 189     ppr sty (ClassOpSig var ty pragmas _)
 190       = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
 191              4 (ppAbove (ppr sty ty)
 192                         (ifnotPprForUser sty (ppr sty pragmas)))
 193
 194     ppr sty (DeforestSig var _)
 195       = ppHang (ppCat [ppStr "{-# DEFOREST", ppr sty var])
 196                    4 (ppStr "#-}")
 197
 198     ppr sty (SpecSig var ty using _)
 199       = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), ppr sty var, ppPStr SLIT("::")])
 200              4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
 201       where
 202         pp_using Nothing   = ppNil
 203         pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
 204
 205     ppr sty (InlineSig var _ _)
 206       = ppHang (ppCat [ppPStr SLIT("{-# INLINE"), ppr sty var])
 207              4 (ppCat [ppPStr SLIT("<enthusiasm not done yet>"), ppPStr SLIT("#-}")])
 208
 209     ppr sty (MagicUnfoldingSig var str _)
 210       = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), ppr sty var, ppPStr str, ppPStr SLIT("#-}")]
 211 \end{code}
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection[AbsSyn-Bind]{Binding: @Bind@}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 data Bind bdee pat              -- binders and bindees
 221   = EmptyBind   -- because it's convenient when parsing signatures
 222   | NonRecBind  (MonoBinds bdee pat)
 223   | RecBind     (MonoBinds bdee pat)
 224 \end{code}
 225
 226 The corresponding unparameterised synonyms:
 227
 228 \begin{code}
 229 type ProtoNameBind              = Bind ProtoName ProtoNamePat
 230 type RenamedBind        = Bind Name RenamedPat
 231 type TypecheckedBind    = Bind Id          TypecheckedPat
 232 \end{code}
 233
 234 \begin{code}
 235 nullBind :: Bind bdee pat -> Bool
 236 nullBind EmptyBind              = True
 237 nullBind (NonRecBind bs)        = nullMonoBinds bs
 238 nullBind (RecBind bs)           = nullMonoBinds bs
 239 \end{code}
 240
 241 \begin{code}
 242 bindIsRecursive :: TypecheckedBind -> Bool
 243 bindIsRecursive EmptyBind       = False
 244 bindIsRecursive (NonRecBind _)  = False
 245 bindIsRecursive (RecBind _)     = True
 246 \end{code}
 247
 248 \begin{code}
 249 instance (NamedThing bdee, Outputable bdee,
 250              NamedThing pat, Outputable pat) =>
 251                 Outputable (Bind bdee pat) where
 252     ppr sty EmptyBind = ppNil
 253     ppr sty (NonRecBind binds)
 254      = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
 255                (ppr sty binds)
 256     ppr sty (RecBind binds)
 257      = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
 258                (ppr sty binds)
 259 \end{code}
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection[AbsSyn-MonoBinds]{Bindings: @MonoBinds@}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 Global bindings (where clauses)
 268
 269 \begin{code}
 270 data MonoBinds bdee pat         -- binders and bindees
 271   = EmptyMonoBinds                      -- TRANSLATION
 272   | AndMonoBinds    (MonoBinds bdee pat)
 273                     (MonoBinds bdee pat)
 274   | PatMonoBind     pat
 275                     (GRHSsAndBinds bdee pat)
 276                     SrcLoc
 277   | VarMonoBind     Id                  -- TRANSLATION
 278                     (Expr bdee pat)
 279   | FunMonoBind     bdee
 280                     [Match bdee pat]    -- must have at least one Match
 281                     SrcLoc
 282 \end{code}
 283
 284 The corresponding unparameterised synonyms:
 285 \begin{code}
 286 type ProtoNameMonoBinds     = MonoBinds ProtoName ProtoNamePat
 287 type RenamedMonoBinds       = MonoBinds Name      RenamedPat
 288 type TypecheckedMonoBinds   = MonoBinds Id        TypecheckedPat
 289 \end{code}
 290
 291 \begin{code}
 292 nullMonoBinds :: MonoBinds bdee pat -> Bool
 293 nullMonoBinds EmptyMonoBinds            = True
 294 nullMonoBinds (AndMonoBinds bs1 bs2)    = (nullMonoBinds bs1) && (nullMonoBinds bs2)
 295 nullMonoBinds other_monobind            = False
 296 \end{code}
 297
 298 \begin{code}
 299 instance (NamedThing bdee, Outputable bdee,
 300              NamedThing pat, Outputable pat) =>
 301                 Outputable (MonoBinds bdee pat) where
 302     ppr sty EmptyMonoBinds = ppNil
 303     ppr sty (AndMonoBinds binds1 binds2)
 304      = ppAbove (ppr sty binds1) (ppr sty binds2)
 305
 306     ppr sty (PatMonoBind pat grhss_n_binds locn)
 307      = ppAboves [
 308             ifPprShowAll sty (ppr sty locn),
 309             (if (hasType pat) then
 310                 ppHang (ppCat [ppr sty pat, ppStr "::"]) 4 (pprUniType sty (getType pat))
 311             else
 312                 ppNil
 313             ),
 314             (ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)) ]
 315
 316     ppr sty (FunMonoBind fun matches locn)
 317      = ppAboves [
 318             ifPprShowAll sty (ppr sty locn),
 319             if (hasType fun) then
 320                 ppHang (ppCat [pprNonOp sty fun, ppStr "::"]) 4
 321                        (pprUniType sty (getType fun))
 322             else
 323                 ppNil,
 324            pprMatches sty (False, pprNonOp sty fun) matches
 325        ]
 326
 327     ppr sty (VarMonoBind name expr)
 328      = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
 329 \end{code}