2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Desugar]{@deSugar@: the main function}
7 module Desugar ( deSugar, pprDsWarnings ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( opt_D_dump_ds )
12 import HsSyn ( MonoBinds )
13 import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl )
16 import PprCore ( pprCoreBindings )
18 import DsBinds ( dsMonoBinds )
19 import DsForeign ( dsForeigns )
22 import Bag ( isEmptyBag )
23 import BasicTypes ( Module )
24 import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
25 import CoreLift ( liftCoreBindings )
26 import CoreLint ( lintCoreBindings )
27 import Id ( nullIdEnv, GenId, Id )
28 import ErrUtils ( dumpIfSet, doIfSet )
30 import UniqSupply ( splitUniqSupply, UniqSupply )
33 The only trick here is to get the @DsMonad@ stuff off to a good
37 deSugar :: UniqSupply -- name supply
38 -> Module -- module name
39 -> TypecheckedMonoBinds
40 -> [TypecheckedForeignDecl]
41 -> IO ([CoreBinding], SDoc, SDoc, SDoc) -- output
43 deSugar us mod_name all_binds fo_decls
45 (us1, us2) = splitUniqSupply us
46 (us3, us4) = splitUniqSupply us2
48 module_and_group = (mod_name, grp_name)
49 grp_name = case opt_SccGroup of
51 Nothing -> mod_name -- default: module name
53 (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group
54 (dsMonoBinds opt_SccProfilingOn all_binds [])
56 ((fi_binds, fe_binds, hc_code, h_code, c_code), ds_warns2) =
57 initDs us3 nullIdEnv module_and_group
60 ds_binds' = liftCoreBindings us4 [Rec (core_prs)]
61 ds_binds = fi_binds ++ ds_binds' ++ fe_binds
64 -- Display any warnings
65 doIfSet (not (isEmptyBag ds_warns))
66 (printErrs (pprDsWarnings ds_warns)) >>
68 -- Lint result if necessary
69 lintCoreBindings "Desugarer" False ds_binds >>
72 dumpIfSet opt_D_dump_ds "Desugared:"
73 (pprCoreBindings ds_binds) >>
75 return (ds_binds, hc_code, h_code, c_code)