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 Type             ( Type )
  17 import TysWiredIn       ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy )
  18 import Panic            ( panic )
  19 \end{code}
  20
  21 Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
  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 True) = mkTupleTy (length pats) (map outPatType pats)
  33 outPatType (TuplePat pats False)= mkUnboxedTupleTy (length pats) (map outPatType pats)
  34 outPatType (RecPat _ ty _ _ _)  = ty
  35 outPatType (LitPat lit ty)      = ty
  36 outPatType (NPat lit ty _)      = ty
  37 outPatType (NPlusKPat _ _ ty _ _) = ty
  38 outPatType (DictPat ds ms)      = case (length ds_ms) of
  39                                     0 -> unitTy
  40                                     1 -> idType (head ds_ms)
  41                                     n -> mkTupleTy n (map idType ds_ms)
  42                                    where
  43                                     ds_ms = ds ++ ms
  44 \end{code}
  45
  46
  47 Nota bene: DsBinds relies on the fact that at least for simple
  48 tuple patterns @collectTypedPatBinders@ returns the binders in
  49 the same order as they appear in the tuple.
  50
  51 collectTypedBinders and collectedTypedPatBinders are the exportees.
  52
  53 \begin{code}
  54 collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
  55 collectTypedMonoBinders EmptyMonoBinds          = []
  56 collectTypedMonoBinders (PatMonoBind pat _ _)   = collectTypedPatBinders pat
  57 collectTypedMonoBinders (FunMonoBind f _ _ _)   = [f]
  58 collectTypedMonoBinders (VarMonoBind v _)       = [v]
  59 collectTypedMonoBinders (CoreMonoBind v _)      = [v]
  60 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  61  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
  62 collectTypedMonoBinders (AbsBinds _ _ exports _ _)
  63   = [global | (_, global, local) <- exports]
  64
  65 collectTypedPatBinders :: TypecheckedPat -> [Id]
  66 collectTypedPatBinders (VarPat var)            = [var]
  67 collectTypedPatBinders (LazyPat pat)           = collectTypedPatBinders pat
  68 collectTypedPatBinders (AsPat a pat)           = a : collectTypedPatBinders pat
  69 collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
  70 collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
  71 collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
  72 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
  73                                                           fields)
  74 collectTypedPatBinders (DictPat ds ms)         = ds ++ ms
  75 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
  76 collectTypedPatBinders any_other_pat           = [ {-no binders-} ]
  77 \end{code}