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 module DsHsSyn where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( OutPat(..), MonoBinds(..),
  12                           HsExpr, GRHSsAndBinds, Match, HsLit )
  13 import TcHsSyn          ( TypecheckedPat,
  14                           TypecheckedMonoBinds )
  15
  16 import Id               ( idType, Id )
  17 import Type             ( Type )
  18 import TysWiredIn       ( mkListTy, mkTupleTy, unitTy )
  19 import Util             ( panic )
  20 \end{code}
  21
  22 Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
  23 then something is wrong.
  24 \begin{code}
  25 outPatType :: TypecheckedPat -> Type
  26
  27 outPatType (WildPat ty)         = ty
  28 outPatType (VarPat var)         = idType var
  29 outPatType (LazyPat pat)        = outPatType pat
  30 outPatType (AsPat var pat)      = idType var
  31 outPatType (ConPat _ ty _)      = ty
  32 outPatType (ConOpPat _ _ _ ty)  = ty
  33 outPatType (ListPat ty _)       = mkListTy ty
  34 outPatType (TuplePat pats)      = mkTupleTy (length pats) (map outPatType pats)
  35 outPatType (RecPat _ ty _)      = ty
  36 outPatType (LitPat lit ty)      = ty
  37 outPatType (NPat lit ty _)      = ty
  38 outPatType (NPlusKPat _ _ 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 collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
  56 collectTypedMonoBinders EmptyMonoBinds        = []
  57 collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
  58 collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
  59 collectTypedMonoBinders (VarMonoBind v _)     = [v]
  60 collectTypedMonoBinders (CoreMonoBind v _)     = [v]
  61 collectTypedMonoBinders (AndMonoBinds bs1 bs2)
  62  = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
  63 collectTypedMonoBinders (AbsBinds _ _ exports _)
  64   = [global | (_, global, local) <- exports]
  65
  66 collectTypedPatBinders :: TypecheckedPat -> [Id]
  67 collectTypedPatBinders (VarPat var)         = [var]
  68 collectTypedPatBinders (LazyPat pat)        = collectTypedPatBinders pat
  69 collectTypedPatBinders (AsPat a pat)        = a : collectTypedPatBinders pat
  70 collectTypedPatBinders (ConPat _ _ pats)    = concat (map collectTypedPatBinders pats)
  71 collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
  72 collectTypedPatBinders (ListPat t pats)     = concat (map collectTypedPatBinders pats)
  73 collectTypedPatBinders (TuplePat pats)      = concat (map collectTypedPatBinders pats)
  74 collectTypedPatBinders (RecPat _ _ fields)  = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields)
  75 collectTypedPatBinders (DictPat ds ms)      = ds ++ ms
  76 collectTypedPatBinders any_other_pat        = [ {-no binders-} ]
  77 \end{code}