ghc/compiler/deSugar/DsHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[DsHsSyn]{Haskell abstract syntax---added things for desugarer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module DsHsSyn where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( OutPat(..), HsBinds(..), MonoBinds(..),
  14                           Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
  15 import TcHsSyn          ( SYN_IE(TypecheckedPat),
  16                           SYN_IE(TypecheckedMonoBinds) )
  17
  18 import Id               ( idType, SYN_IE(Id) )
  19 import Type             ( SYN_IE(Type) )
  20 import TysWiredIn       ( mkListTy, mkTupleTy, unitTy )
  21 import Util             ( panic )
  22 \end{code}
  23
  24 Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
  25 then something is wrong.
  26 \begin{code}
  27 outPatType :: TypecheckedPat -> Type
  28
  29 outPatType (WildPat ty)         = ty
  30 outPatType (VarPat var)         = idType var
  31 outPatType (LazyPat pat)        = outPatType pat
  32 outPatType (AsPat var pat)      = idType var
  33 outPatType (ConPat _ ty _)      = ty
  34 outPatType (ConOpPat _ _ _ ty)  = ty
  35 outPatType (ListPat ty _)       = mkListTy ty
  36 outPatType (TuplePat pats)      = mkTupleTy (length pats) (map outPatType pats)
  37 outPatType (RecPat _ ty _)      = ty
  38 outPatType (LitPat lit ty)      = ty
  39 outPatType (NPat lit ty _)      = ty
  40 outPatType (NPlusKPat _ _ ty _ _) = ty
  41 outPatType (DictPat ds ms)      = case (length ds_ms) of
  42                                     0 -> unitTy
  43                                     1 -> idType (head ds_ms)
  44                                     n -> mkTupleTy n (map idType ds_ms)
  45                                    where
  46                                     ds_ms = ds ++ ms
  47 \end{code}
  48
  49
  50 Nota bene: DsBinds relies on the fact that at least for simple
  51 tuple patterns @collectTypedPatBinders@ returns the binders in
  52 the same order as they appear in the tuple.
  53
  54 collectTypedBinders and collectedTypedPatBinders are the exportees.
  55
  56 \begin{code}
  57 collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
  58 collectTypedMonoBinders EmptyMonoBinds        = []
  59 collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
  60 collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
  61 collectTypedMonoBinders (VarMonoBind v _)     = [v]
  62 collectTypedMonoBinders (CoreMonoBind v _)     = [v]
  63 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  64  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
  65 collectTypedMonoBinders (AbsBinds _ _ exports _)
  66   = [global | (_, global, local) <- exports]
  67
  68 collectTypedPatBinders :: TypecheckedPat -> [Id]
  69 collectTypedPatBinders (VarPat var)         = [var]
  70 collectTypedPatBinders (LazyPat pat)        = collectTypedPatBinders pat
  71 collectTypedPatBinders (AsPat a pat)        = a : collectTypedPatBinders pat
  72 collectTypedPatBinders (ConPat _ _ pats)    = concat (map collectTypedPatBinders pats)
  73 collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
  74 collectTypedPatBinders (ListPat t pats)     = concat (map collectTypedPatBinders pats)
  75 collectTypedPatBinders (TuplePat pats)      = concat (map collectTypedPatBinders pats)
  76 collectTypedPatBinders (RecPat _ _ fields)  = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields)
  77 collectTypedPatBinders (DictPat ds ms)      = ds ++ ms
  78 collectTypedPatBinders any_other_pat        = [ {-no binders-} ]
  79 \end{code}