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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Desugar]{@deSugar@: the main function}
\begin{code}
#include "HsVersions.h"
module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
import CoreSyn
import DsMonad
import DsBinds ( dsBinds, dsInstBinds )
import DsUtils
import Bag ( unionBags )
import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import CoreLift ( liftCoreBindings )
import CoreLint ( lintCoreBindings )
import Id ( nullIdEnv, mkIdEnv )
import PprStyle ( PprStyle(..) )
import UniqSupply ( splitUniqSupply )
\end{code}
The only trick here is to get the @DsMonad@ stuff off to a good
start.
\begin{code}
deSugar :: UniqSupply -- name supply
-> FAST_STRING -- module name
-> (TypecheckedHsBinds, -- input: recsel, class, instance, and value
TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
TypecheckedHsBinds, -- them)
TypecheckedHsBinds,
[(Id, TypecheckedHsExpr)])
-- ToDo: handling of const_inst thingies is certainly WRONG ***************************
-> ([CoreBinding], -- output
Bag DsMatchContext) -- Shadowing complaints
deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs)
= let
(us0, us0a) = splitUniqSupply us
(us1, us1a) = splitUniqSupply us0a
(us2, us2a) = splitUniqSupply us1a
(us3, us3a) = splitUniqSupply us2a
(us4, us5) = splitUniqSupply us3a
auto_meth = opt_AutoSccsOnAllToplevs
auto_top = opt_AutoSccsOnAllToplevs
|| opt_AutoSccsOnExportedToplevs
((core_const_prs, consts_pairs), shadows1)
= initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
consts_env = mkIdEnv consts_pairs
(core_clas_binds, shadows2)
= initDs us1 consts_env mod_name (dsBinds False clas_binds)
core_clas_prs = pairsFromCoreBinds core_clas_binds
(core_inst_binds, shadows3)
= initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds)
core_inst_prs = pairsFromCoreBinds core_inst_binds
(core_val_binds, shadows4)
= initDs us3 consts_env mod_name (dsBinds auto_top val_binds)
core_val_pairs = pairsFromCoreBinds core_val_binds
(core_recsel_binds, shadows5)
= initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds)
core_recsel_prs = pairsFromCoreBinds core_recsel_binds
final_binds
= if (null core_clas_prs && null core_inst_prs
&& null core_recsel_prs {-???dont know???-} && null core_const_prs) then
-- we don't have to make the whole thing recursive
core_clas_binds ++ core_val_binds
else -- gotta make it recursive (sigh)
[Rec (core_clas_prs ++ core_inst_prs
++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)]
lift_final_binds = liftCoreBindings us5 final_binds
really_final_binds = if opt_DoCoreLinting
then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
else lift_final_binds
shadows = shadows1 `unionBags` shadows2 `unionBags`
shadows3 `unionBags` shadows4 `unionBags` shadows5
in
(really_final_binds, shadows)
\end{code}
|
