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.
21 import Module ( Module, moduleString )
22 import Bag ( isEmptyBag, unionBags )
23 import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
24 import CoreLint ( beginPass, endPass )
25 import ErrUtils ( doIfSet, pprBagOfWarnings )
27 import UniqSupply ( splitUniqSupply, UniqSupply )
30 The only trick here is to get the @DsMonad@ stuff off to a good
34 deSugar :: UniqSupply -- name supply
35 -> ValueEnv -- value env
36 -> Module -- module name
37 -> TypecheckedMonoBinds
38 -> [TypecheckedForeignDecl]
39 -> IO ([CoreBind], SDoc, SDoc) -- output
41 deSugar us global_val_env mod_name all_binds fo_decls = do
44 let (core_prs, ds_warns1) = initDs us1 global_val_env module_and_group
45 (dsMonoBinds opt_SccProfilingOn all_binds [])
46 ds_binds' = [Rec core_prs]
48 ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
49 initDs us3 global_val_env module_and_group (dsForeigns mod_name fo_decls)
51 ds_binds = fi_binds ++ ds_binds' ++ fe_binds
53 ds_warns = ds_warns1 `unionBags` ds_warns2
55 -- Display any warnings
56 doIfSet (not (isEmptyBag ds_warns))
57 (printErrs (pprBagOfWarnings ds_warns))
59 -- Lint result if necessary
60 endPass "Desugar" opt_D_dump_ds ds_binds
61 return (ds_binds, h_code, c_code)
63 (us1, us2) = splitUniqSupply us
64 (us3, us4) = splitUniqSupply us2
66 module_and_group = (mod_name, grp_name)
67 grp_name = case opt_SccGroup of
69 Nothing -> _PK_ (moduleString mod_name) -- default: module name