ghc/compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Desugar]{@deSugar@: the main function}
   5
   6 \begin{code}
   7 module Desugar ( deSugar, pprDsWarnings ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( opt_D_dump_ds )
  12 import HsSyn            ( MonoBinds )
  13 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedForeignDecl )
  14
  15 import CoreSyn
  16 import PprCore          ( pprCoreBindings )
  17 import DsMonad
  18 import DsBinds          ( dsMonoBinds )
  19 import DsForeign        ( dsForeigns )
  20 import DsUtils
  21
  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 )
  29 import Outputable
  30 import UniqSupply       ( splitUniqSupply, UniqSupply )
  31 \end{code}
  32
  33 The only trick here is to get the @DsMonad@ stuff off to a good
  34 start.
  35
  36 \begin{code}
  37 deSugar :: UniqSupply           -- name supply
  38         -> Module               -- module name
  39         -> TypecheckedMonoBinds
  40         -> [TypecheckedForeignDecl]
  41         -> IO ([CoreBinding], SDoc, SDoc, SDoc) -- output
  42
  43 deSugar us mod_name all_binds fo_decls
  44   = let
  45         (us1, us2) = splitUniqSupply us
  46         (us3, us4) = splitUniqSupply us2
  47
  48         module_and_group = (mod_name, grp_name)
  49         grp_name  = case opt_SccGroup of
  50                         Just xx -> _PK_ xx
  51                         Nothing -> mod_name     -- default: module name
  52
  53         (core_prs, ds_warns) = initDs us1 nullIdEnv module_and_group
  54                                (dsMonoBinds opt_SccProfilingOn all_binds [])
  55
  56         ((fi_binds, fe_binds, hc_code, h_code, c_code), ds_warns2) =
  57                    initDs us3 nullIdEnv module_and_group
  58                          (dsForeigns fo_decls)
  59
  60         ds_binds' = liftCoreBindings us4 [Rec (core_prs)]
  61         ds_binds  = fi_binds ++ ds_binds' ++ fe_binds
  62     in
  63
  64         -- Display any warnings
  65     doIfSet (not (isEmptyBag ds_warns))
  66         (printErrs (pprDsWarnings ds_warns)) >>
  67
  68         -- Lint result if necessary
  69     lintCoreBindings "Desugarer" False ds_binds >>
  70
  71         -- Dump output
  72     dumpIfSet opt_D_dump_ds "Desugared:"
  73         (pprCoreBindings ds_binds)      >>
  74
  75     return (ds_binds, hc_code, h_code, c_code)
  76 \end{code}