ghc/compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   5
   6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
  14 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds )
  15
  16 -- friends:
  17 import HsPragmas        ( GenPragmas, ClassOpPragmas )
  18 import HsTypes          ( HsType )
  19 import CoreSyn          ( CoreExpr )
  20 import PprCore          ()         -- Instances for Outputable
  21
  22 --others:
  23 import Id               ( DictVar, Id, GenId )
  24 import Name             ( OccName, NamedThing(..) )
  25 import BasicTypes       ( RecFlag(..) )
  26 import Outputable
  27 import Bag
  28 import SrcLoc           ( SrcLoc )
  29 import Type             ( GenType )
  30 import TyVar            ( GenTyVar )
  31 \end{code}
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsection{Bindings: @HsBinds@}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 The following syntax may produce new syntax which is not part of the input,
  40 and which is instead a translation of the input to the typechecker.
  41 Syntax translations are marked TRANSLATION in comments. New empty
  42 productions are useful in development but may not appear in the final
  43 grammar.
  44
  45 Collections of bindings, created by dependency analysis and translation:
  46
  47 \begin{code}
  48 data HsBinds flexi id pat               -- binders and bindees
  49   = EmptyBinds
  50
  51   | ThenBinds   (HsBinds flexi id pat)
  52                 (HsBinds flexi id pat)
  53
  54   | MonoBind    (MonoBinds flexi id pat)
  55                 [Sig id]                -- Empty on typechecker output
  56                 RecFlag
  57 \end{code}
  58
  59 \begin{code}
  60 nullBinds :: HsBinds flexi id pat -> Bool
  61
  62 nullBinds EmptyBinds            = True
  63 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  64 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  65 \end{code}
  66
  67 \begin{code}
  68 instance (Outputable pat, NamedThing id, Outputable id) =>
  69                 Outputable (HsBinds flexi id pat) where
  70     ppr binds = ppr_binds binds
  71
  72 ppr_binds EmptyBinds = empty
  73 ppr_binds (ThenBinds binds1 binds2)
  74      = ($$) (ppr_binds binds1) (ppr_binds binds2)
  75 ppr_binds (MonoBind bind sigs is_rec)
  76      = vcat [ifNotPprForUser (ptext rec_str),
  77              vcat (map ppr sigs),
  78              ppr bind
  79        ]
  80      where
  81        rec_str = case is_rec of
  82                    Recursive    -> SLIT("{- rec -}")
  83                    NonRecursive -> SLIT("{- nonrec -}")
  84 \end{code}
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsection{Bindings: @MonoBinds@}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 Global bindings (where clauses)
  93
  94 \begin{code}
  95 data MonoBinds flexi id pat
  96   = EmptyMonoBinds
  97
  98   | AndMonoBinds    (MonoBinds flexi id pat)
  99                     (MonoBinds flexi id pat)
 100
 101   | PatMonoBind     pat
 102                     (GRHSsAndBinds flexi id pat)
 103                     SrcLoc
 104
 105   | FunMonoBind     id
 106                     Bool                        -- True => infix declaration
 107                     [Match flexi id pat]        -- must have at least one Match
 108                     SrcLoc
 109
 110   | VarMonoBind     id                  -- TRANSLATION
 111                     (HsExpr flexi id pat)
 112
 113   | CoreMonoBind    id                  -- TRANSLATION
 114                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 115
 116   | AbsBinds                    -- Binds abstraction; TRANSLATION
 117                 [GenTyVar flexi]          -- Type variables
 118                 [id]                      -- Dicts
 119                 [([GenTyVar flexi], id, id)]  -- (type variables, polymorphic, momonmorphic) triples
 120                 (MonoBinds flexi id pat)      -- The "business end"
 121
 122         -- Creates bindings for *new* (polymorphic, overloaded) locals
 123         -- in terms of *old* (monomorphic, non-overloaded) ones.
 124         --
 125         -- See section 9 of static semantics paper for more details.
 126         -- (You can get a PhD for explaining the True Meaning
 127         --  of this last construct.)
 128 \end{code}
 129
 130 What AbsBinds means
 131 ~~~~~~~~~~~~~~~~~~~
 132          AbsBinds tvs
 133                   [d1,d2]
 134                   [(tvs1, f1p, f1m),
 135                    (tvs2, f2p, f2m)]
 136                   BIND
 137 means
 138
 139         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 140                                       in fm
 141
 142         gp = ...same again, with gm instead of fm
 143
 144 This is a pretty bad translation, because it duplicates all the bindings.
 145 So the desugarer tries to do a better job:
 146
 147         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 148                                         (fm,gm) -> fm
 149         ..ditto for gp..
 150
 151         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 152                                       in (fm,gm)
 153
 154 \begin{code}
 155 nullMonoBinds :: MonoBinds flexi id pat -> Bool
 156
 157 nullMonoBinds EmptyMonoBinds         = True
 158 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 159 nullMonoBinds other_monobind         = False
 160
 161 andMonoBinds :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat
 162 andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
 163 \end{code}
 164
 165 \begin{code}
 166 instance (NamedThing id, Outputable id, Outputable pat) =>
 167                 Outputable (MonoBinds flexi id pat) where
 168     ppr mbind = ppr_monobind mbind
 169
 170
 171 ppr_monobind EmptyMonoBinds = empty
 172 ppr_monobind (AndMonoBinds binds1 binds2)
 173       = ($$) (ppr_monobind binds1) (ppr_monobind binds2)
 174
 175 ppr_monobind (PatMonoBind pat grhss_n_binds locn)
 176       = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)]
 177
 178 ppr_monobind (FunMonoBind fun inf matches locn)
 179       = pprMatches (False, ppr fun) matches
 180       -- ToDo: print infix if appropriate
 181
 182 ppr_monobind (VarMonoBind name expr)
 183       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 184
 185 ppr_monobind (CoreMonoBind name expr)
 186       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 187
 188 ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
 189      = ($$) (sep [ptext SLIT("AbsBinds"),
 190                   brackets (interpp'SP tyvars),
 191                   brackets (interpp'SP dictvars),
 192                   brackets (interpp'SP exports)])
 193                (nest 4 (ppr val_binds))
 194 \end{code}
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 203 ``specialise this function to these four types...'') in with type
 204 signatures.  Then all the machinery to move them into place, etc.,
 205 serves for both.
 206
 207 \begin{code}
 208 data Sig name
 209   = Sig         name            -- a bog-std type signature
 210                 (HsType name)
 211                 SrcLoc
 212
 213   | ClassOpSig  name                    -- Selector name
 214                 (Maybe name)            -- Default-method name (if any)
 215                 (HsType name)
 216                 SrcLoc
 217
 218   | SpecSig     name            -- specialise a function or datatype ...
 219                 (HsType name) -- ... to these types
 220                 (Maybe name)    -- ... maybe using this as the code for it
 221                 SrcLoc
 222
 223   | InlineSig   name              -- INLINE f
 224                 SrcLoc
 225
 226   | MagicUnfoldingSig
 227                 name            -- Associate the "name"d function with
 228                 FAST_STRING     -- the compiler-builtin unfolding (known
 229                 SrcLoc          -- by the String name)
 230 \end{code}
 231
 232 \begin{code}
 233 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 234     ppr sig = ppr_sig sig
 235
 236
 237 ppr_sig (Sig var ty _)
 238       = sep [ppr var <+> ptext SLIT("::"),
 239              nest 4 (ppr ty)]
 240
 241 ppr_sig (ClassOpSig var _ ty _)
 242       = sep [ppr (getOccName var) <+> ptext SLIT("::"),
 243              nest 4 (ppr ty)]
 244
 245 ppr_sig (SpecSig var ty using _)
 246       = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")],
 247               nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
 248         ]
 249       where
 250         pp_using Nothing   = empty
 251         pp_using (Just me) = hsep [char '=', ppr me]
 252
 253 ppr_sig (InlineSig var _)
 254         = hsep [text "{-# INLINE", ppr var, text "#-}"]
 255
 256 ppr_sig (MagicUnfoldingSig var str _)
 257       = hsep [text "{-# MAGIC_UNFOLDING", ppr var, ptext str, text "#-}"]
 258 \end{code}
 259