ghc/compiler/deSugar/DsHsSyn.lhs

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