ghc/compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Desugar]{@deSugar@: the main function}
   5
   6 \begin{code}
   7 module Desugar ( deSugar ) where
   8
   9 #include "HsVersions.h"
  10
  11 import CmdLineOpts      ( opt_D_dump_ds )
  12 import HsSyn            ( MonoBinds )
  13 import TcHsSyn          ( TypecheckedMonoBinds, TypecheckedForeignDecl )
  14 import CoreSyn
  15 import DsMonad
  16 import DsBinds          ( dsMonoBinds )
  17 import DsForeign        ( dsForeigns )
  18 import DsUtils
  19 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  20                                 -- depends on DsExpr.hi-boot.
  21
  22 import Bag              ( isEmptyBag )
  23 import BasicTypes       ( Module )
  24 import CmdLineOpts      ( opt_SccGroup, opt_SccProfilingOn )
  25 import CoreLint         ( beginPass, endPass )
  26 import ErrUtils         ( doIfSet )
  27 import Outputable
  28 import UniqSupply       ( splitUniqSupply, UniqSupply )
  29 \end{code}
  30
  31 The only trick here is to get the @DsMonad@ stuff off to a good
  32 start.
  33
  34 \begin{code}
  35 deSugar :: UniqSupply           -- name supply
  36         -> GlobalValueEnv       -- value env
  37         -> Module               -- module name
  38         -> TypecheckedMonoBinds
  39         -> [TypecheckedForeignDecl]
  40         -> IO ([CoreBind], SDoc, SDoc) -- output
  41
  42 deSugar us global_val_env mod_name all_binds fo_decls = do
  43         beginPass "Desugar"
  44         -- Do desugaring
  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]
  48
  49             ((fi_binds, fe_binds, h_code, c_code), ds_warns2) =
  50                     initDs us3 global_val_env module_and_group (dsForeigns fo_decls)
  51
  52             ds_binds  = fi_binds ++ ds_binds' ++ fe_binds
  53
  54          -- Display any warnings
  55         doIfSet (not (isEmptyBag ds_warns))
  56                 (printErrs (pprDsWarnings ds_warns))
  57
  58          -- Lint result if necessary
  59         endPass "Desugar" opt_D_dump_ds ds_binds
  60         return (ds_binds, h_code, c_code)
  61   where
  62     (us1, us2) = splitUniqSupply us
  63     (us3, us4) = splitUniqSupply us2
  64
  65     module_and_group = (mod_name, grp_name)
  66     grp_name  = case opt_SccGroup of
  67                   Just xx -> _PK_ xx
  68                   Nothing -> mod_name   -- default: module name
  69
  70 \end{code}