2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Desugar]{@deSugar@: the main function}
7 #include "HsVersions.h"
12 -- and to make the interface self-sufficient...
13 SplitUniqSupply, Binds, Expr, Id, TypecheckedPat,
14 CoreBinding, GlobalSwitch, SwitchResult,
15 Bag, DsMatchContext, DsMatchKind
19 import AbsSyn -- the stuff being desugared
20 import PlainCore -- the output of desugaring;
21 -- importing this module also gets all the
22 -- CoreSyn utility functions
23 import DsMonad -- the monadery used in the desugarer
25 import Bag ( unionBags, Bag )
26 import CmdLineOpts ( switchIsOn, GlobalSwitch(..), SwitchResult )
27 import CoreLift ( liftCoreBindings )
28 import CoreLint ( lintCoreBindings )
29 import DsBinds ( dsBinds, dsInstBinds )
31 import Pretty ( PprStyle(..) )
36 The only trick here is to get the @DesugarMonad@ stuff off to a good
40 deSugar :: SplitUniqSupply -- name supply
41 -> (GlobalSwitch->SwitchResult) -- switch looker upper
42 -> FAST_STRING -- module name
44 -> (TypecheckedBinds, -- input: class, instance, and value
45 TypecheckedBinds, -- bindings; see "tcModule" (which produces
46 TypecheckedBinds, -- them)
47 [(Inst, TypecheckedExpr)])
48 -- ToDo: handling of const_inst thingies is certainly WRONG ***************************
50 -> ([PlainCoreBinding], -- output
51 Bag DsMatchContext) -- Shadowing complaints
53 deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
55 (us0, us0a) = splitUniqSupply us
56 (us1, us1a) = splitUniqSupply us0a
57 (us2, us2a) = splitUniqSupply us1a
58 (us3, us4) = splitUniqSupply us2a
60 ((core_const_prs, consts_pairs), shadows1)
61 = initDs us0 nullIdEnv sw_chkr mod_name (dsInstBinds [] const_inst_pairs)
63 consts_env = mkIdEnv consts_pairs
65 (core_clas_binds, shadows2)
66 = initDs us1 consts_env sw_chkr mod_name (dsBinds clas_binds)
67 core_clas_prs = pairsFromCoreBinds core_clas_binds
69 (core_inst_binds, shadows3)
70 = initDs us2 consts_env sw_chkr mod_name (dsBinds inst_binds)
71 core_inst_prs = pairsFromCoreBinds core_inst_binds
73 (core_val_binds, shadows4)
74 = initDs us3 consts_env sw_chkr mod_name (dsBinds val_binds)
75 core_val_pairs = pairsFromCoreBinds core_val_binds
78 = if (null core_clas_prs && null core_inst_prs && null core_const_prs) then
79 -- we don't have to make the whole thing recursive
80 core_clas_binds ++ core_val_binds
82 else -- gotta make it recursive (sigh)
83 [CoRec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
85 lift_final_binds = {-if switchIsOn sw_chkr GlasgowExts
86 then-} liftCoreBindings us4 final_binds
89 really_final_binds = if switchIsOn sw_chkr DoCoreLinting
90 then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
93 shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4
95 (really_final_binds, shadows)