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