Desugar.lhs 3.16 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
4
5
6
7
8
%
\section[Desugar]{@deSugar@: the main function}

\begin{code}
#include "HsVersions.h"

9
module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
10

11
IMP_Ubiq(){-uitous-}
12

13
import HsSyn		( HsBinds, HsExpr )
14
import TcHsSyn		( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
15
import CoreSyn
16

17
18
19
import DsMonad
import DsBinds		( dsBinds, dsInstBinds )
import DsUtils
20

21
import Bag		( unionBags )
22
import CmdLineOpts	( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
23
24
import CoreLift		( liftCoreBindings )
import CoreLint		( lintCoreBindings )
25
26
27
import Id		( nullIdEnv, mkIdEnv )
import PprStyle		( PprStyle(..) )
import UniqSupply	( splitUniqSupply )
28
29
\end{code}

30
The only trick here is to get the @DsMonad@ stuff off to a good
31
32
33
start.

\begin{code}
34
deSugar :: UniqSupply		-- name supply
35
36
	-> FAST_STRING			-- module name

37
38
	-> (TypecheckedHsBinds, -- input: recsel, class, instance, and value
	    TypecheckedHsBinds, --   bindings; see "tcModule" (which produces
39
	    TypecheckedHsBinds,	--   them)
40
	    TypecheckedHsBinds,
41
	    [(Id, TypecheckedHsExpr)])
42
43
-- ToDo: handling of const_inst thingies is certainly WRONG ***************************

44
	-> ([CoreBinding],	-- output
45
46
	    Bag DsMatchContext)	-- Shadowing complaints

47
deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs)
48
49
50
51
  = let
	(us0, us0a) = splitUniqSupply us
	(us1, us1a) = splitUniqSupply us0a
	(us2, us2a) = splitUniqSupply us1a
52
53
	(us3, us3a) = splitUniqSupply us2a
	(us4, us5)  = splitUniqSupply us3a
54

55
56
57
58
	auto_meth = opt_AutoSccsOnAllToplevs 
	auto_top  = opt_AutoSccsOnAllToplevs
		    || opt_AutoSccsOnExportedToplevs

59
	((core_const_prs, consts_pairs), shadows1)
60
	    = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
61
62
63
64

	consts_env = mkIdEnv consts_pairs

	(core_clas_binds, shadows2)
65
			= initDs us1 consts_env mod_name (dsBinds False clas_binds)
66
	core_clas_prs	= pairsFromCoreBinds core_clas_binds
67

68
	(core_inst_binds, shadows3)
69
			= initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds)
70
	core_inst_prs	= pairsFromCoreBinds core_inst_binds
71

72
	(core_val_binds, shadows4)
73
			= initDs us3 consts_env mod_name (dsBinds auto_top val_binds)
74
75
	core_val_pairs	= pairsFromCoreBinds core_val_binds

76
	(core_recsel_binds, shadows5)
77
			= initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds)
78
79
	core_recsel_prs	= pairsFromCoreBinds core_recsel_binds

80
    	final_binds
81
82
	  = if (null core_clas_prs && null core_inst_prs
	     && null core_recsel_prs {-???dont know???-} && null core_const_prs) then
83
84
85
86
		-- we don't have to make the whole thing recursive
		core_clas_binds ++ core_val_binds

	    else -- gotta make it recursive (sigh)
87
88
	       [Rec (core_clas_prs ++ core_inst_prs
		  ++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)]
89

90
	lift_final_binds = liftCoreBindings us5 final_binds
91

92
	really_final_binds = if opt_DoCoreLinting
93
94
95
			     then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
			     else lift_final_binds

96
97
	shadows = shadows1 `unionBags` shadows2 `unionBags`
		  shadows3 `unionBags` shadows4 `unionBags` shadows5
98
99
100
    in
    (really_final_binds, shadows)
\end{code}