compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   5
   6 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
  14                                MatchGroup, pprFunBind,
  15                                GRHSs, pprPatBind )
  16 import {-# SOURCE #-} HsPat  ( LPat )
  17
  18 import HsTypes          ( LHsType, PostTcType )
  19 import PprCore          ( {- instances -} )
  20 import Coercion         ( Coercion )
  21 import Type             ( Type, pprParendType )
  22 import Name             ( Name )
  23 import NameSet          ( NameSet, elemNameSet )
  24 import BasicTypes       ( IPName, RecFlag(..), InlineSpec(..), Fixity )
  25 import Outputable
  26 import SrcLoc           ( Located(..), SrcSpan, unLoc )
  27 import Util             ( sortLe )
  28 import Var              ( TyVar, DictId, Id, Var )
  29 import Bag              ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
  30 \end{code}
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{Bindings: @BindGroup@}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 Global bindings (where clauses)
  39
  40 \begin{code}
  41 data HsLocalBinds id    -- Bindings in a 'let' expression
  42                         -- or a 'where' clause
  43   = HsValBinds (HsValBinds id)
  44   | HsIPBinds  (HsIPBinds id)
  45
  46   | EmptyLocalBinds
  47
  48 data HsValBinds id      -- Value bindings (not implicit parameters)
  49   = ValBindsIn                          -- Before typechecking
  50         (LHsBinds id) [LSig id]         -- Not dependency analysed
  51                                         -- Recursive by default
  52
  53   | ValBindsOut                         -- After renaming
  54         [(RecFlag, LHsBinds id)]        -- Dependency analysed
  55         [LSig Name]
  56
  57 type LHsBinds id  = Bag (LHsBind id)
  58 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
  59 type LHsBind  id  = Located (HsBind id)
  60
  61 data HsBind id
  62   = FunBind {   -- FunBind is used for both functions   f x = e
  63                 -- and variables                        f = \x -> e
  64 -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
  65 --
  66 -- Reason 2: instance decls can only have FunBinds, which is convenient
  67 --           If you change this, you'll need tochange e.g. rnMethodBinds
  68
  69 -- But note that the form       f :: a->a = ...
  70 -- parses as a pattern binding, just like
  71 --                      (f :: a -> a) = ...
  72
  73         fun_id :: Located id,
  74
  75         fun_infix :: Bool,      -- True => infix declaration
  76
  77         fun_matches :: MatchGroup id,   -- The payload
  78
  79         fun_co_fn :: ExprCoFn,  -- Coercion from the type of the MatchGroup to the type of
  80                                 -- the Id.  Example:
  81                                 --      f :: Int -> forall a. a -> a
  82                                 --      f x y = y
  83                                 -- Then the MatchGroup will have type (Int -> a' -> a')
  84                                 -- (with a free type variable a').  The coercion will take
  85                                 -- a CoreExpr of this type and convert it to a CoreExpr of
  86                                 -- type         Int -> forall a'. a' -> a'
  87                                 -- Notice that the coercion captures the free a'.  That's
  88                                 -- why coercions are (CoreExpr -> CoreExpr), rather than
  89                                 -- just CoreExpr (with a functional type)
  90
  91         bind_fvs :: NameSet     -- After the renamer, this contains a superset of the
  92                                 -- Names of the other binders in this binding group that
  93                                 -- are free in the RHS of the defn
  94                                 -- Before renaming, and after typechecking,
  95                                 -- the field is unused; it's just an error thunk
  96     }
  97
  98   | PatBind {   -- The pattern is never a simple variable;
  99                 -- That case is done by FunBind
 100         pat_lhs    :: LPat id,
 101         pat_rhs    :: GRHSs id,
 102         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
 103         bind_fvs   :: NameSet           -- Same as for FunBind
 104     }
 105
 106   | VarBind {   -- Dictionary binding and suchlike
 107         var_id :: id,           -- All VarBinds are introduced by the type checker
 108         var_rhs :: LHsExpr id   -- Located only for consistency
 109     }
 110
 111   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
 112         abs_tvs     :: [TyVar],
 113         abs_dicts   :: [DictId],
 114         abs_exports :: [([TyVar], id, id, [Prag])],     -- (tvs, poly_id, mono_id, prags)
 115         abs_binds   :: LHsBinds id              -- The dictionary bindings and typechecked user bindings
 116                                                 -- mixed up together; you can tell the dict bindings because
 117                                                 -- they are all VarBinds
 118     }
 119         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 120         --
 121         -- Creates bindings for (polymorphic, overloaded) poly_f
 122         -- in terms of monomorphic, non-overloaded mono_f
 123         --
 124         -- Invariants:
 125         --      1. 'binds' binds mono_f
 126         --      2. ftvs is a subset of tvs
 127         --      3. ftvs includes all tyvars free in ds
 128         --
 129         -- See section 9 of static semantics paper for more details.
 130         -- (You can get a PhD for explaining the True Meaning
 131         --  of this last construct.)
 132
 133 placeHolderNames :: NameSet
 134 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 135 placeHolderNames = panic "placeHolderNames"
 136
 137 ------------
 138 instance OutputableBndr id => Outputable (HsLocalBinds id) where
 139   ppr (HsValBinds bs) = ppr bs
 140   ppr (HsIPBinds bs)  = ppr bs
 141   ppr EmptyLocalBinds = empty
 142
 143 instance OutputableBndr id => Outputable (HsValBinds id) where
 144   ppr (ValBindsIn binds sigs)
 145    = pprValBindsForUser binds sigs
 146
 147   ppr (ValBindsOut sccs sigs)
 148     = getPprStyle $ \ sty ->
 149       if debugStyle sty then    -- Print with sccs showing
 150         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 151      else
 152         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
 153    where
 154      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 155      pp_rec Recursive    = ptext SLIT("rec")
 156      pp_rec NonRecursive = ptext SLIT("nonrec")
 157
 158 --  *not* pprLHsBinds because we don't want braces; 'let' and
 159 -- 'where' include a list of HsBindGroups and we don't want
 160 -- several groups of bindings each with braces around.
 161 -- Sort by location before printing
 162 pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
 163                    => LHsBinds id1 -> [LSig id2] -> SDoc
 164 pprValBindsForUser binds sigs
 165   = vcat (map snd (sort_by_loc decls))
 166   where
 167
 168     decls :: [(SrcSpan, SDoc)]
 169     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 170             [(loc, ppr bind) | L loc bind <- bagToList binds]
 171
 172     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
 173
 174 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
 175 pprLHsBinds binds
 176   | isEmptyLHsBinds binds = empty
 177   | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
 178
 179 ------------
 180 emptyLocalBinds :: HsLocalBinds a
 181 emptyLocalBinds = EmptyLocalBinds
 182
 183 isEmptyLocalBinds :: HsLocalBinds a -> Bool
 184 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 185 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 186 isEmptyLocalBinds EmptyLocalBinds = True
 187
 188 isEmptyValBinds :: HsValBinds a -> Bool
 189 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 190 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 191
 192 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
 193 emptyValBindsIn  = ValBindsIn emptyBag []
 194 emptyValBindsOut = ValBindsOut []      []
 195
 196 emptyLHsBinds :: LHsBinds id
 197 emptyLHsBinds = emptyBag
 198
 199 isEmptyLHsBinds :: LHsBinds id -> Bool
 200 isEmptyLHsBinds = isEmptyBag
 201
 202 ------------
 203 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 204 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 205   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 206 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 207   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 208 \end{code}
 209
 210 What AbsBinds means
 211 ~~~~~~~~~~~~~~~~~~~
 212          AbsBinds tvs
 213                   [d1,d2]
 214                   [(tvs1, f1p, f1m),
 215                    (tvs2, f2p, f2m)]
 216                   BIND
 217 means
 218
 219         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 220                                       in fm
 221
 222         gp = ...same again, with gm instead of fm
 223
 224 This is a pretty bad translation, because it duplicates all the bindings.
 225 So the desugarer tries to do a better job:
 226
 227         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 228                                         (fm,gm) -> fm
 229         ..ditto for gp..
 230
 231         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 232                                        in (fm,gm)
 233
 234 \begin{code}
 235 instance OutputableBndr id => Outputable (HsBind id) where
 236     ppr mbind = ppr_monobind mbind
 237
 238 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 239
 240 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 241 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
 242 ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
 243       -- ToDo: print infix if appropriate
 244
 245 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
 246                          abs_exports = exports, abs_binds = val_binds })
 247      = sep [ptext SLIT("AbsBinds"),
 248             brackets (interpp'SP tyvars),
 249             brackets (interpp'SP dictvars),
 250             brackets (sep (punctuate comma (map ppr_exp exports)))]
 251        $$
 252        nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 253                         -- Print type signatures
 254                 $$ pprLHsBinds val_binds )
 255   where
 256     ppr_exp (tvs, gbl, lcl, prags)
 257         = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
 258                 nest 2 (vcat (map (pprPrag gbl) prags))]
 259 \end{code}
 260
 261 %************************************************************************
 262 %*                                                                      *
 263                 Implicit parameter bindings
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 data HsIPBinds id
 269   = IPBinds
 270         [LIPBind id]
 271         (DictBinds id)  -- Only in typechecker output; binds
 272                         -- uses of the implicit parameters
 273
 274 isEmptyIPBinds :: HsIPBinds id -> Bool
 275 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
 276
 277 type LIPBind id = Located (IPBind id)
 278
 279 -- | Implicit parameter bindings.
 280 data IPBind id
 281   = IPBind
 282         (IPName id)
 283         (LHsExpr id)
 284
 285 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 286   ppr (IPBinds bs ds) = vcat (map ppr bs)
 287                         $$ pprLHsBinds ds
 288
 289 instance (OutputableBndr id) => Outputable (IPBind id) where
 290   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 291 \end{code}
 292
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection{Coercion functions}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 \begin{code}
 301 -- A ExprCoFn is an expression with a hole in it
 302 -- We need coercions to have concrete form so that we can zonk them
 303
 304 data ExprCoFn
 305   = CoHole                      -- The identity coercion
 306
 307   | CoCompose ExprCoFn ExprCoFn -- (\a1..an. []) `CoCompose` (\x1..xn. [])
 308                                 --      = (\a1..an \x1..xn. [])
 309
 310   | ExprCoFn Coercion           -- A cast:  [] `cast` co
 311                                 -- Guaranteedn not the identity coercion
 312
 313   | CoApp Var                   -- [] x; the xi are dicts or coercions
 314   | CoTyApp Type                -- [] t
 315   | CoLam Id                    -- \x. []; the xi are dicts or coercions
 316   | CoTyLam TyVar               -- \a. []
 317
 318         -- Non-empty bindings, so that the identity coercion
 319         -- is always exactly CoHole
 320   | CoLet (LHsBinds Id)         -- let binds in []
 321                                 -- (ould be nicer to be core bindings)
 322
 323 instance Outputable ExprCoFn where
 324   ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn
 325
 326 pprCoFn :: SDoc -> ExprCoFn -> SDoc
 327 pprCoFn it CoHole = it
 328 pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1
 329 pprCoFn it (ExprCoFn co)     = it <+> ptext SLIT("`cast`") <+> pprParendType co
 330 pprCoFn it (CoApp id)    = it <+> ppr id
 331 pprCoFn it (CoTyApp ty)  = it <+> ptext SLIT("@") <+> pprParendType ty
 332 pprCoFn it (CoLam id)    = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
 333 pprCoFn it (CoTyLam tv)  = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
 334 pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
 335
 336 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
 337 CoHole <.> c = c
 338 c <.> CoHole = c
 339 c1 <.> c2    = c1 `CoCompose` c2
 340
 341 mkCoTyApps :: [Type] -> ExprCoFn
 342 mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys)
 343
 344 mkCoApps :: [Id] -> ExprCoFn
 345 mkCoApps ids = mk_co_fn CoApp (reverse ids)
 346
 347 mkCoTyLams :: [TyVar] -> ExprCoFn
 348 mkCoTyLams ids = mk_co_fn CoTyLam ids
 349
 350 mkCoLams :: [Id] -> ExprCoFn
 351 mkCoLams ids = mk_co_fn CoLam ids
 352
 353 mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn
 354 mk_co_fn f as = foldr (CoCompose . f) CoHole as
 355
 356 idCoercion :: ExprCoFn
 357 idCoercion = CoHole
 358
 359 isIdCoercion :: ExprCoFn -> Bool
 360 isIdCoercion CoHole = True
 361 isIdCoercion other  = False
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 372 ``specialise this function to these four types...'') in with type
 373 signatures.  Then all the machinery to move them into place, etc.,
 374 serves for both.
 375
 376 \begin{code}
 377 type LSig name = Located (Sig name)
 378
 379 data Sig name
 380   = TypeSig     (Located name)  -- A bog-std type signature
 381                 (LHsType name)
 382
 383   | SpecSig     (Located name)  -- Specialise a function or datatype ...
 384                 (LHsType name)  -- ... to these types
 385                 InlineSpec
 386
 387   | InlineSig   (Located name)  -- Function name
 388                 InlineSpec
 389
 390   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 391                                 -- current instance decl
 392
 393   | FixSig      (FixitySig name)        -- Fixity declaration
 394
 395 type LFixitySig name = Located (FixitySig name)
 396 data FixitySig name = FixitySig (Located name) Fixity
 397
 398 -- A Prag conveys pragmas from the type checker to the desugarer
 399 data Prag
 400   = InlinePrag
 401         InlineSpec
 402
 403   | SpecPrag
 404         (HsExpr Id)     -- An expression, of the given specialised type, which
 405         PostTcType      -- specialises the polymorphic function
 406         [Id]            -- Dicts mentioned free in the expression
 407         InlineSpec      -- Inlining spec for the specialised function
 408
 409 isInlinePrag (InlinePrag _) = True
 410 isInlinePrag prag           = False
 411
 412 isSpecPrag (SpecPrag _ _ _ _) = True
 413 isSpecPrag prag               = False
 414 \end{code}
 415
 416 \begin{code}
 417 okBindSig :: NameSet -> LSig Name -> Bool
 418 okBindSig ns sig = sigForThisGroup ns sig
 419
 420 okHsBootSig :: LSig Name -> Bool
 421 okHsBootSig (L _ (TypeSig  _ _)) = True
 422 okHsBootSig (L _ (FixSig _))     = True
 423 okHsBootSig sig                  = False
 424
 425 okClsDclSig :: LSig Name -> Bool
 426 okClsDclSig (L _ (SpecInstSig _)) = False
 427 okClsDclSig sig                   = True        -- All others OK
 428
 429 okInstDclSig :: NameSet -> LSig Name -> Bool
 430 okInstDclSig ns lsig@(L _ sig) = ok ns sig
 431   where
 432     ok ns (TypeSig _ _)   = False
 433     ok ns (FixSig _)      = False
 434     ok ns (SpecInstSig _) = True
 435     ok ns sig             = sigForThisGroup ns lsig
 436
 437 sigForThisGroup :: NameSet -> LSig Name -> Bool
 438 sigForThisGroup ns sig
 439   = case sigName sig of
 440         Nothing -> False
 441         Just n  -> n `elemNameSet` ns
 442
 443 sigName :: LSig name -> Maybe name
 444 sigName (L _ sig) = f sig
 445  where
 446     f (TypeSig   n _)          = Just (unLoc n)
 447     f (SpecSig   n _ _)        = Just (unLoc n)
 448     f (InlineSig n _)          = Just (unLoc n)
 449     f (FixSig (FixitySig n _)) = Just (unLoc n)
 450     f other                     = Nothing
 451
 452 isFixityLSig :: LSig name -> Bool
 453 isFixityLSig (L _ (FixSig {})) = True
 454 isFixityLSig _                 = False
 455
 456 isVanillaLSig :: LSig name -> Bool
 457 isVanillaLSig (L _(TypeSig {})) = True
 458 isVanillaLSig sig               = False
 459
 460 isSpecLSig :: LSig name -> Bool
 461 isSpecLSig (L _(SpecSig {})) = True
 462 isSpecLSig sig               = False
 463
 464 isSpecInstLSig (L _ (SpecInstSig {})) = True
 465 isSpecInstLSig sig                    = False
 466
 467 isPragLSig :: LSig name -> Bool
 468         -- Identifies pragmas
 469 isPragLSig (L _ (SpecSig {}))   = True
 470 isPragLSig (L _ (InlineSig {})) = True
 471 isPragLSig other                = False
 472
 473 isInlineLSig :: LSig name -> Bool
 474         -- Identifies inline pragmas
 475 isInlineLSig (L _ (InlineSig {})) = True
 476 isInlineLSig other                = False
 477
 478 hsSigDoc (TypeSig {})           = ptext SLIT("type signature")
 479 hsSigDoc (SpecSig {})           = ptext SLIT("SPECIALISE pragma")
 480 hsSigDoc (InlineSig _ spec)     = ppr spec <+> ptext SLIT("pragma")
 481 hsSigDoc (SpecInstSig {})       = ptext SLIT("SPECIALISE instance pragma")
 482 hsSigDoc (FixSig {})            = ptext SLIT("fixity declaration")
 483 \end{code}
 484
 485 Signature equality is used when checking for duplicate signatures
 486
 487 \begin{code}
 488 eqHsSig :: LSig Name -> LSig Name -> Bool
 489 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 490 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 491 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2))                 = s1 == s2 && unLoc n1 == unLoc n2
 492         -- For specialisations, we don't have equality over
 493         -- HsType, so it's not convenient to spot duplicate
 494         -- specialisations here.  Check for this later, when we're in Type land
 495 eqHsSig _other1 _other2 = False
 496 \end{code}
 497
 498 \begin{code}
 499 instance (OutputableBndr name) => Outputable (Sig name) where
 500     ppr sig = ppr_sig sig
 501
 502 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 503 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
 504 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 505 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
 506 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 507 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
 508
 509 instance Outputable name => Outputable (FixitySig name) where
 510   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 511
 512 pragBrackets :: SDoc -> SDoc
 513 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
 514
 515 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 516 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 517
 518 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
 519 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 520
 521 pprPrag :: Outputable id => id -> Prag -> SDoc
 522 pprPrag var (InlinePrag inl)         = ppr inl <+> ppr var
 523 pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
 524 \end{code}