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(..), Bind(..), MonoBinds(..),
  14                           Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
  15 import TcHsSyn          ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedBind),
  16                           SYN_IE(TypecheckedMonoBinds) )
  17
  18 import Id               ( idType )
  19 import TysWiredIn       ( mkListTy, mkTupleTy, unitTy )
  20 import Util             ( panic )
  21 \end{code}
  22
  23 Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
  24 then something is wrong.
  25 \begin{code}
  26 outPatType :: TypecheckedPat -> Type
  27
  28 outPatType (WildPat ty)         = ty
  29 outPatType (VarPat var)         = idType var
  30 outPatType (LazyPat pat)        = outPatType pat
  31 outPatType (AsPat var pat)      = idType var
  32 outPatType (ConPat _ ty _)      = ty
  33 outPatType (ConOpPat _ _ _ ty)  = ty
  34 outPatType (ListPat ty _)       = mkListTy ty
  35 outPatType (TuplePat pats)      = mkTupleTy (length pats) (map outPatType pats)
  36 outPatType (RecPat _ ty _)      = ty
  37 outPatType (LitPat lit ty)      = ty
  38 outPatType (NPat lit ty _)      = ty
  39 outPatType (DictPat ds ms)      = case (length ds_ms) of
  40                                     0 -> unitTy
  41                                     1 -> idType (head ds_ms)
  42                                     n -> mkTupleTy n (map idType ds_ms)
  43                                    where
  44                                     ds_ms = ds ++ ms
  45 \end{code}
  46
  47
  48 Nota bene: DsBinds relies on the fact that at least for simple
  49 tuple patterns @collectTypedPatBinders@ returns the binders in
  50 the same order as they appear in the tuple.
  51
  52 collectTypedBinders and collectedTypedPatBinders are the exportees.
  53
  54 \begin{code}
  55 collectTypedBinders :: TypecheckedBind -> [Id]
  56 collectTypedBinders EmptyBind       = []
  57 collectTypedBinders (NonRecBind bs) = collectTypedMonoBinders bs
  58 collectTypedBinders (RecBind    bs) = collectTypedMonoBinders bs
  59
  60 collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
  61 collectTypedMonoBinders EmptyMonoBinds        = []
  62 collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
  63 collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
  64 collectTypedMonoBinders (VarMonoBind v _)     = [v]
  65 collectTypedMonoBinders (CoreMonoBind v _)     = [v]
  66 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  67  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
  68
  69 collectTypedPatBinders :: TypecheckedPat -> [Id]
  70 collectTypedPatBinders (VarPat var)         = [var]
  71 collectTypedPatBinders (LazyPat pat)        = collectTypedPatBinders pat
  72 collectTypedPatBinders (AsPat a pat)        = a : collectTypedPatBinders pat
  73 collectTypedPatBinders (ConPat _ _ pats)    = concat (map collectTypedPatBinders pats)
  74 collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
  75 collectTypedPatBinders (ListPat t pats)     = concat (map collectTypedPatBinders pats)
  76 collectTypedPatBinders (TuplePat pats)      = concat (map collectTypedPatBinders pats)
  77 collectTypedPatBinders (RecPat _ _ fields)  = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields)
  78 collectTypedPatBinders (DictPat ds ms)      = ds ++ ms
  79 collectTypedPatBinders any_other_pat        = [ {-no binders-} ]
  80 \end{code}