2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Desugar]{@deSugar@: the main function}
7 module Desugar ( deSugar ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( opt_D_dump_ds )
12 import HsSyn ( MonoBinds )
13 import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl )
16 import DsBinds ( dsMonoBinds )
17 import DsForeign ( dsForeigns )
19 import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
20 -- depends on DsExpr.hi-boot.
22 import Bag ( isEmptyBag )
23 import BasicTypes ( Module )
24 import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
25 import CoreLint ( beginPass, endPass )
26 import ErrUtils ( doIfSet )
28 import UniqSupply ( splitUniqSupply, UniqSupply )
31 The only trick here is to get the @DsMonad@ stuff off to a good
35 deSugar :: UniqSupply -- name supply
36 -> GlobalValueEnv -- value env
37 -> Module -- module name
38 -> TypecheckedMonoBinds
39 -> [TypecheckedForeignDecl]
40 -> IO ([CoreBind], SDoc, SDoc) -- output
42 deSugar us global_val_env mod_name all_binds fo_decls = do
45 let (core_prs, ds_warns) = initDs us1 global_val_env module_and_group
46 (dsMonoBinds opt_SccProfilingOn all_binds [])
47 ds_binds' = [Rec core_prs]
49 ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
50 initDs us3 global_val_env module_and_group (dsForeigns fo_decls)
52 ds_binds = fi_binds ++ ds_binds' ++ fe_binds
54 -- Display any warnings
55 doIfSet (not (isEmptyBag ds_warns))
56 (printErrs (pprDsWarnings ds_warns))
58 -- Lint result if necessary
59 endPass "Desugar" opt_D_dump_ds ds_binds
60 return (ds_binds, h_code, c_code)
62 (us1, us2) = splitUniqSupply us
63 (us3, us4) = splitUniqSupply us2
65 module_and_group = (mod_name, grp_name)
66 grp_name = case opt_SccGroup of
68 Nothing -> mod_name -- default: module name